This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add socklen_t probe; Configure maintenance.
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW
1/* pp_sys.c
2 *
3818b22b 3 * Copyright (c) 1991-2000, Larry Wall
a0d0e21e
LW
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * But only a short way ahead its floor and the walls on either side were
12 * cloven by a great fissure, out of which the red glare came, now leaping
13 * up, now dying down into darkness; and all the while far below there was
14 * a rumour and a trouble as of great engines throbbing and labouring.
15 */
16
17#include "EXTERN.h"
864dbfa3 18#define PERL_IN_PP_SYS_C
a0d0e21e
LW
19#include "perl.h"
20
f1066039
JH
21#ifdef I_SHADOW
22/* Shadow password support for solaris - pdo@cs.umd.edu
23 * Not just Solaris: at least HP-UX, IRIX, Linux.
24 * the API is from SysV. --jhi */
5b3db61d
DL
25#ifdef __hpux__
26/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
27 * and another MAXINT from "perl.h" <- <sys/param.h>. */
28#undef MAXINT
29#endif
8c0bfa08
PB
30#include <shadow.h>
31#endif
32
76c32331
PP
33/* XXX If this causes problems, set i_unistd=undef in the hint file. */
34#ifdef I_UNISTD
35# include <unistd.h>
36#endif
37
8ac85365
NIS
38#ifdef HAS_SYSCALL
39#ifdef __cplusplus
40extern "C" int syscall(unsigned long,...);
41#endif
42#endif
43
76c32331
PP
44#ifdef I_SYS_WAIT
45# include <sys/wait.h>
46#endif
47
48#ifdef I_SYS_RESOURCE
49# include <sys/resource.h>
16d20bd9 50#endif
a0d0e21e
LW
51
52#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
53# include <sys/socket.h>
29209bc5 54# if defined(USE_SOCKS) && defined(I_SOCKS)
86959918
JH
55# include <socks.h>
56# endif
3fd537d4
JH
57# ifdef I_NETDB
58# include <netdb.h>
59# endif
a0d0e21e
LW
60# ifndef ENOTSOCK
61# ifdef I_NET_ERRNO
62# include <net/errno.h>
63# endif
64# endif
65#endif
66
67#ifdef HAS_SELECT
68#ifdef I_SYS_SELECT
a0d0e21e
LW
69#include <sys/select.h>
70#endif
71#endif
a0d0e21e 72
dc45a647
MB
73/* XXX Configure test needed.
74 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS
75 applications, see "extern int errno in perl.h". Creating such
76 a test requires taking into account the differences between
77 compiling multithreaded and singlethreaded ($ccflags et al).
78 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647 79*/
df4e335f 80#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
a0d0e21e
LW
81extern int h_errno;
82#endif
83
84#ifdef HAS_PASSWD
85# ifdef I_PWD
86# include <pwd.h>
87# else
20ce7b12
GS
88 struct passwd *getpwnam (char *);
89 struct passwd *getpwuid (Uid_t);
a0d0e21e 90# endif
28e8609d 91# ifdef HAS_GETPWENT
20ce7b12 92 struct passwd *getpwent (void);
28e8609d 93# endif
a0d0e21e
LW
94#endif
95
96#ifdef HAS_GROUP
97# ifdef I_GRP
98# include <grp.h>
99# else
20ce7b12
GS
100 struct group *getgrnam (char *);
101 struct group *getgrgid (Gid_t);
a0d0e21e 102# endif
28e8609d 103# ifdef HAS_GETGRENT
20ce7b12 104 struct group *getgrent (void);
28e8609d 105# endif
a0d0e21e
LW
106#endif
107
108#ifdef I_UTIME
3730b96e 109# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1
PP
110# include <sys/utime.h>
111# else
112# include <utime.h>
113# endif
a0d0e21e 114#endif
a0d0e21e 115
54310121
PP
116/* Put this after #includes because fork and vfork prototypes may conflict. */
117#ifndef HAS_VFORK
118# define vfork fork
119#endif
120
13b3f787
JH
121/* Put this after #includes because <unistd.h> defines _XOPEN_*.
122 * Sock_size_t is defined identically in doio.c. */
d574b85e 123#ifndef Sock_size_t
13b3f787
JH
124# ifdef HAS_SOCKLEN_T
125# define Sock_size_t socklen_t
d574b85e 126# else
13b3f787
JH
127# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
128# define Sock_size_t Size_t
129# else
130# define Sock_size_t int
131# endif
d574b85e 132# endif
54310121
PP
133#endif
134
cbdc8872 135#ifdef HAS_CHSIZE
cd52b7b2
PP
136# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
137# undef my_chsize
138# endif
6ad3d225 139# define my_chsize PerlLIO_chsize
cbdc8872
PP
140#endif
141
ff68c719
PP
142#ifdef HAS_FLOCK
143# define FLOCK flock
144#else /* no flock() */
145
36477c24
PP
146 /* fcntl.h might not have been included, even if it exists, because
147 the current Configure only sets I_FCNTL if it's needed to pick up
148 the *_OK constants. Make sure it has been included before testing
149 the fcntl() locking constants. */
150# if defined(HAS_FCNTL) && !defined(I_FCNTL)
151# include <fcntl.h>
152# endif
153
ff68c719
PP
154# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
155# define FLOCK fcntl_emulate_flock
156# define FCNTL_EMULATE_FLOCK
157# else /* no flock() or fcntl(F_SETLK,...) */
158# ifdef HAS_LOCKF
159# define FLOCK lockf_emulate_flock
160# define LOCKF_EMULATE_FLOCK
161# endif /* lockf */
162# endif /* no flock() or fcntl(F_SETLK,...) */
163
164# ifdef FLOCK
20ce7b12 165 static int FLOCK (int, int);
ff68c719
PP
166
167 /*
168 * These are the flock() constants. Since this sytems doesn't have
169 * flock(), the values of the constants are probably not available.
170 */
171# ifndef LOCK_SH
172# define LOCK_SH 1
173# endif
174# ifndef LOCK_EX
175# define LOCK_EX 2
176# endif
177# ifndef LOCK_NB
178# define LOCK_NB 4
179# endif
180# ifndef LOCK_UN
181# define LOCK_UN 8
182# endif
183# endif /* emulating flock() */
184
185#endif /* no flock() */
55497cff 186
85ab1d1d
JH
187#define ZBTLEN 10
188static char zero_but_true[ZBTLEN + 1] = "0 but true";
189
5ff3f7a4
GS
190#if defined(I_SYS_ACCESS) && !defined(R_OK)
191# include <sys/access.h>
192#endif
193
37bd1396
GS
194#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
195# define FD_CLOEXEC 1 /* NeXT needs this */
196#endif
197
5ff3f7a4
GS
198#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
199#undef PERL_EFF_ACCESS_W_OK
200#undef PERL_EFF_ACCESS_X_OK
201
202/* F_OK unused: if stat() cannot find it... */
203
204#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 205 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS
206# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
207# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
208# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
209#endif
210
211#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS
212# if defined(I_SYS_SECURITY)
213# include <sys/security.h>
214# endif
c955f117
JH
215 /* XXX Configure test needed for eaccess */
216# ifdef ACC_SELF
217 /* HP SecureWare */
218# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
219# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
220# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
221# else
222 /* SCO */
223# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
224# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
225# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
226# endif
5ff3f7a4
GS
227#endif
228
229#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 230 /* AIX */
5ff3f7a4
GS
231# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
232# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
233# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
234#endif
235
327c3667
GS
236#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
237 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
238 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 239/* The Hard Way. */
327c3667 240STATIC int
7f4774ae 241S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 242{
5ff3f7a4
GS
243 Uid_t ruid = getuid();
244 Uid_t euid = geteuid();
245 Gid_t rgid = getgid();
246 Gid_t egid = getegid();
247 int res;
248
1feb2720 249 LOCK_CRED_MUTEX;
5ff3f7a4 250#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 251 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS
252#else
253#ifdef HAS_SETREUID
254 if (setreuid(euid, ruid))
255#else
256#ifdef HAS_SETRESUID
257 if (setresuid(euid, ruid, (Uid_t)-1))
258#endif
259#endif
cea2e8a9 260 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS
261#endif
262
263#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 264 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS
265#else
266#ifdef HAS_SETREGID
267 if (setregid(egid, rgid))
268#else
269#ifdef HAS_SETRESGID
270 if (setresgid(egid, rgid, (Gid_t)-1))
271#endif
272#endif
cea2e8a9 273 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS
274#endif
275
276 res = access(path, mode);
277
278#ifdef HAS_SETREUID
279 if (setreuid(ruid, euid))
280#else
281#ifdef HAS_SETRESUID
282 if (setresuid(ruid, euid, (Uid_t)-1))
283#endif
284#endif
cea2e8a9 285 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS
286
287#ifdef HAS_SETREGID
288 if (setregid(rgid, egid))
289#else
290#ifdef HAS_SETRESGID
291 if (setresgid(rgid, egid, (Gid_t)-1))
292#endif
293#endif
cea2e8a9 294 Perl_croak(aTHX_ "leaving effective gid failed");
1feb2720 295 UNLOCK_CRED_MUTEX;
5ff3f7a4
GS
296
297 return res;
298}
299# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
300# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
301# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
302#endif
303
304#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 305STATIC int
7f4774ae 306S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 307{
cea2e8a9 308 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS
309 /*NOTREACHED*/
310 return -1;
311}
312#endif
313
a0d0e21e
LW
314PP(pp_backtick)
315{
4e35701f 316 djSP; dTARGET;
760ac839 317 PerlIO *fp;
2d8e6c8d
GS
318 STRLEN n_a;
319 char *tmps = POPpx;
54310121
PP
320 I32 gimme = GIMME_V;
321
a0d0e21e 322 TAINT_PROPER("``");
6ad3d225 323 fp = PerlProc_popen(tmps, "r");
a0d0e21e 324 if (fp) {
54310121 325 if (gimme == G_VOID) {
96827780
MB
326 char tmpbuf[256];
327 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121
PP
328 /*SUPPRESS 530*/
329 ;
330 }
331 else if (gimme == G_SCALAR) {
aa689395 332 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW
333 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
334 /*SUPPRESS 530*/
335 ;
336 XPUSHs(TARG);
aa689395 337 SvTAINTED_on(TARG);
a0d0e21e
LW
338 }
339 else {
340 SV *sv;
341
342 for (;;) {
8d6dde3e 343 sv = NEWSV(56, 79);
a0d0e21e
LW
344 if (sv_gets(sv, fp, 0) == Nullch) {
345 SvREFCNT_dec(sv);
346 break;
347 }
348 XPUSHs(sv_2mortal(sv));
349 if (SvLEN(sv) - SvCUR(sv) > 20) {
350 SvLEN_set(sv, SvCUR(sv)+1);
351 Renew(SvPVX(sv), SvLEN(sv), char);
352 }
aa689395 353 SvTAINTED_on(sv);
a0d0e21e
LW
354 }
355 }
6ad3d225 356 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 357 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW
358 }
359 else {
f86702cc 360 STATUS_NATIVE_SET(-1);
54310121 361 if (gimme == G_SCALAR)
a0d0e21e
LW
362 RETPUSHUNDEF;
363 }
364
365 RETURN;
366}
367
368PP(pp_glob)
369{
370 OP *result;
f5284f61
IZ
371 tryAMAGICunTARGET(iter, -1);
372
a0d0e21e 373 ENTER;
a0d0e21e 374
c90c0ff4 375#ifndef VMS
3280af22 376 if (PL_tainting) {
7bac28a0
PP
377 /*
378 * The external globbing program may use things we can't control,
379 * so for security reasons we must assume the worst.
380 */
381 TAINT;
22c35a8c 382 taint_proper(PL_no_security, "glob");
7bac28a0 383 }
c90c0ff4 384#endif /* !VMS */
7bac28a0 385
3280af22
NIS
386 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
387 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 388
3280af22 389 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 390 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd
PP
391#ifndef DOSISH
392#ifndef CSH
6b88bc9c 393 *SvPVX(PL_rs) = '\n';
a0d0e21e 394#endif /* !CSH */
55497cff 395#endif /* !DOSISH */
c07a80fd 396
a0d0e21e
LW
397 result = do_readline();
398 LEAVE;
399 return result;
400}
401
15e52e56 402#if 0 /* XXX never used! */
a0d0e21e
LW
403PP(pp_indread)
404{
2d8e6c8d
GS
405 STRLEN n_a;
406 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW
407 return do_readline();
408}
15e52e56 409#endif
a0d0e21e
LW
410
411PP(pp_rcatline)
412{
638eceb6 413 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW
414 return do_readline();
415}
416
417PP(pp_warn)
418{
4e35701f 419 djSP; dMARK;
06bf62c7 420 SV *tmpsv;
a0d0e21e 421 char *tmps;
06bf62c7 422 STRLEN len;
a0d0e21e
LW
423 if (SP - MARK != 1) {
424 dTARGET;
3280af22 425 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 426 tmpsv = TARG;
a0d0e21e
LW
427 SP = MARK + 1;
428 }
429 else {
06bf62c7 430 tmpsv = TOPs;
a0d0e21e 431 }
06bf62c7
GS
432 tmps = SvPV(tmpsv, len);
433 if (!tmps || !len) {
4e6ea2c3
GS
434 SV *error = ERRSV;
435 (void)SvUPGRADE(error, SVt_PV);
436 if (SvPOK(error) && SvCUR(error))
437 sv_catpv(error, "\t...caught");
06bf62c7
GS
438 tmpsv = error;
439 tmps = SvPV(tmpsv, len);
a0d0e21e 440 }
06bf62c7
GS
441 if (!tmps || !len)
442 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
443
894356b3 444 Perl_warn(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW
445 RETSETYES;
446}
447
448PP(pp_die)
449{
4e35701f 450 djSP; dMARK;
a0d0e21e 451 char *tmps;
06bf62c7
GS
452 SV *tmpsv;
453 STRLEN len;
454 bool multiarg = 0;
a0d0e21e
LW
455 if (SP - MARK != 1) {
456 dTARGET;
3280af22 457 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS
458 tmpsv = TARG;
459 tmps = SvPV(tmpsv, len);
460 multiarg = 1;
a0d0e21e
LW
461 SP = MARK + 1;
462 }
463 else {
4e6ea2c3 464 tmpsv = TOPs;
06bf62c7 465 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 466 }
06bf62c7 467 if (!tmps || !len) {
4e6ea2c3
GS
468 SV *error = ERRSV;
469 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS
470 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
471 if (!multiarg)
4e6ea2c3 472 SvSetSV(error,tmpsv);
06bf62c7 473 else if (sv_isobject(error)) {
05423cc9
GS
474 HV *stash = SvSTASH(SvRV(error));
475 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
476 if (gv) {
ed094faf 477 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
57843af0 478 SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop)));
05423cc9
GS
479 EXTEND(SP, 3);
480 PUSHMARK(SP);
481 PUSHs(error);
482 PUSHs(file);
483 PUSHs(line);
484 PUTBACK;
864dbfa3
GS
485 call_sv((SV*)GvCV(gv),
486 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 487 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS
488 }
489 }
cea2e8a9 490 DIE(aTHX_ Nullch);
4e6ea2c3
GS
491 }
492 else {
493 if (SvPOK(error) && SvCUR(error))
494 sv_catpv(error, "\t...propagated");
06bf62c7
GS
495 tmpsv = error;
496 tmps = SvPV(tmpsv, len);
4e6ea2c3 497 }
a0d0e21e 498 }
06bf62c7
GS
499 if (!tmps || !len)
500 tmpsv = sv_2mortal(newSVpvn("Died", 4));
501
894356b3 502 DIE(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW
503}
504
505/* I/O. */
506
507PP(pp_open)
508{
4e35701f 509 djSP; dTARGET;
a0d0e21e
LW
510 GV *gv;
511 SV *sv;
6170680b
IZ
512 SV *name;
513 I32 have_name = 0;
a0d0e21e
LW
514 char *tmps;
515 STRLEN len;
4592e6ca 516 MAGIC *mg;
a0d0e21e 517
6170680b
IZ
518 if (MAXARG > 2) {
519 name = POPs;
520 have_name = 1;
521 }
a0d0e21e
LW
522 if (MAXARG > 1)
523 sv = POPs;
5f05dabc 524 if (!isGV(TOPs))
cea2e8a9 525 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc
PP
526 if (MAXARG <= 1)
527 sv = GvSV(TOPs);
a0d0e21e 528 gv = (GV*)POPs;
5f05dabc 529 if (!isGV(gv))
cea2e8a9 530 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24
PP
531 if (GvIOp(gv))
532 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 533
4592e6ca
NIS
534 if (mg = SvTIED_mg((SV*)gv, 'q')) {
535 PUSHMARK(SP);
536 XPUSHs(SvTIED_obj((SV*)gv, mg));
537 XPUSHs(sv);
6170680b
IZ
538 if (have_name)
539 XPUSHs(name);
4592e6ca
NIS
540 PUTBACK;
541 ENTER;
864dbfa3 542 call_method("OPEN", G_SCALAR);
4592e6ca
NIS
543 LEAVE;
544 SPAGAIN;
545 RETURN;
546 }
547
a0d0e21e 548 tmps = SvPV(sv, len);
6170680b 549 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS
550 PUSHi( (I32)PL_forkprocess );
551 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW
552 PUSHi(0);
553 else
554 RETPUSHUNDEF;
555 RETURN;
556}
557
558PP(pp_close)
559{
4e35701f 560 djSP;
a0d0e21e 561 GV *gv;
1d603a67 562 MAGIC *mg;
a0d0e21e
LW
563
564 if (MAXARG == 0)
3280af22 565 gv = PL_defoutgv;
a0d0e21e
LW
566 else
567 gv = (GV*)POPs;
1d603a67 568
33c27489 569 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 570 PUSHMARK(SP);
33c27489 571 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB
572 PUTBACK;
573 ENTER;
864dbfa3 574 call_method("CLOSE", G_SCALAR);
1d603a67
GB
575 LEAVE;
576 SPAGAIN;
577 RETURN;
578 }
a0d0e21e 579 EXTEND(SP, 1);
54310121 580 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW
581 RETURN;
582}
583
584PP(pp_pipe_op)
585{
4e35701f 586 djSP;
a0d0e21e
LW
587#ifdef HAS_PIPE
588 GV *rgv;
589 GV *wgv;
590 register IO *rstio;
591 register IO *wstio;
592 int fd[2];
593
594 wgv = (GV*)POPs;
595 rgv = (GV*)POPs;
596
597 if (!rgv || !wgv)
598 goto badexit;
599
4633a7c4 600 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 601 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW
602 rstio = GvIOn(rgv);
603 wstio = GvIOn(wgv);
604
605 if (IoIFP(rstio))
606 do_close(rgv, FALSE);
607 if (IoIFP(wstio))
608 do_close(wgv, FALSE);
609
6ad3d225 610 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW
611 goto badexit;
612
760ac839
LW
613 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
614 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
615 IoIFP(wstio) = IoOFP(wstio);
616 IoTYPE(rstio) = '<';
617 IoTYPE(wstio) = '>';
618
619 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 620 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 621 else PerlLIO_close(fd[0]);
760ac839 622 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 623 else PerlLIO_close(fd[1]);
a0d0e21e
LW
624 goto badexit;
625 }
4771b018
GS
626#if defined(HAS_FCNTL) && defined(F_SETFD)
627 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
628 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
629#endif
a0d0e21e
LW
630 RETPUSHYES;
631
632badexit:
633 RETPUSHUNDEF;
634#else
cea2e8a9 635 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW
636#endif
637}
638
639PP(pp_fileno)
640{
4e35701f 641 djSP; dTARGET;
a0d0e21e
LW
642 GV *gv;
643 IO *io;
760ac839 644 PerlIO *fp;
4592e6ca
NIS
645 MAGIC *mg;
646
a0d0e21e
LW
647 if (MAXARG < 1)
648 RETPUSHUNDEF;
649 gv = (GV*)POPs;
4592e6ca
NIS
650
651 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
652 PUSHMARK(SP);
653 XPUSHs(SvTIED_obj((SV*)gv, mg));
654 PUTBACK;
655 ENTER;
864dbfa3 656 call_method("FILENO", G_SCALAR);
4592e6ca
NIS
657 LEAVE;
658 SPAGAIN;
659 RETURN;
660 }
661
a0d0e21e
LW
662 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
663 RETPUSHUNDEF;
760ac839 664 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW
665 RETURN;
666}
667
668PP(pp_umask)
669{
4e35701f 670 djSP; dTARGET;
761237fe 671 Mode_t anum;
a0d0e21e
LW
672
673#ifdef HAS_UMASK
674 if (MAXARG < 1) {
6ad3d225
GS
675 anum = PerlLIO_umask(0);
676 (void)PerlLIO_umask(anum);
a0d0e21e
LW
677 }
678 else
6ad3d225 679 anum = PerlLIO_umask(POPi);
a0d0e21e
LW
680 TAINT_PROPER("umask");
681 XPUSHi(anum);
682#else
eec2d3df
GS
683 /* Only DIE if trying to restrict permissions on `user' (self).
684 * Otherwise it's harmless and more useful to just return undef
685 * since 'group' and 'other' concepts probably don't exist here. */
686 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 687 DIE(aTHX_ "umask not implemented");
6b88bc9c 688 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
689#endif
690 RETURN;
691}
692
693PP(pp_binmode)
694{
4e35701f 695 djSP;
a0d0e21e
LW
696 GV *gv;
697 IO *io;
760ac839 698 PerlIO *fp;
4592e6ca 699 MAGIC *mg;
a0d0e21e
LW
700
701 if (MAXARG < 1)
702 RETPUSHUNDEF;
703
4592e6ca
NIS
704 gv = (GV*)POPs;
705
706 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
707 PUSHMARK(SP);
708 XPUSHs(SvTIED_obj((SV*)gv, mg));
709 PUTBACK;
710 ENTER;
864dbfa3 711 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS
712 LEAVE;
713 SPAGAIN;
714 RETURN;
715 }
a0d0e21e
LW
716
717 EXTEND(SP, 1);
718 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 719 RETPUSHUNDEF;
a0d0e21e 720
491527d0 721 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW
722 RETPUSHYES;
723 else
724 RETPUSHUNDEF;
a0d0e21e
LW
725}
726
b8e3bfaf 727
a0d0e21e
LW
728PP(pp_tie)
729{
4e35701f 730 djSP;
e336de0d 731 dMARK;
a0d0e21e
LW
732 SV *varsv;
733 HV* stash;
734 GV *gv;
a0d0e21e 735 SV *sv;
3280af22 736 I32 markoff = MARK - PL_stack_base;
a0d0e21e 737 char *methname;
6b05c17a 738 int how = 'P';
e336de0d 739 U32 items;
2d8e6c8d 740 STRLEN n_a;
a0d0e21e 741
e336de0d 742 varsv = *++MARK;
6b05c17a
NIS
743 switch(SvTYPE(varsv)) {
744 case SVt_PVHV:
745 methname = "TIEHASH";
746 break;
747 case SVt_PVAV:
748 methname = "TIEARRAY";
749 break;
750 case SVt_PVGV:
751 methname = "TIEHANDLE";
752 how = 'q';
753 break;
754 default:
755 methname = "TIESCALAR";
756 how = 'q';
757 break;
758 }
e336de0d
GS
759 items = SP - MARK++;
760 if (sv_isobject(*MARK)) {
6b05c17a 761 ENTER;
e788e7d3 762 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
763 PUSHMARK(SP);
764 EXTEND(SP,items);
765 while (items--)
766 PUSHs(*MARK++);
767 PUTBACK;
864dbfa3 768 call_method(methname, G_SCALAR);
6b05c17a
NIS
769 }
770 else {
864dbfa3 771 /* Not clear why we don't call call_method here too.
6b05c17a
NIS
772 * perhaps to get different error message ?
773 */
e336de0d 774 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 775 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 776 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 777 methname, SvPV(*MARK,n_a));
6b05c17a
NIS
778 }
779 ENTER;
e788e7d3 780 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
781 PUSHMARK(SP);
782 EXTEND(SP,items);
783 while (items--)
784 PUSHs(*MARK++);
785 PUTBACK;
864dbfa3 786 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 787 }
a0d0e21e
LW
788 SPAGAIN;
789
790 sv = TOPs;
d3acc0f7 791 POPSTACK;
a0d0e21e 792 if (sv_isobject(sv)) {
33c27489
GS
793 sv_unmagic(varsv, how);
794 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW
795 }
796 LEAVE;
3280af22 797 SP = PL_stack_base + markoff;
a0d0e21e
LW
798 PUSHs(sv);
799 RETURN;
800}
801
802PP(pp_untie)
803{
4e35701f 804 djSP;
33c27489
GS
805 SV *sv = POPs;
806 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 807
599cee73 808 if (ckWARN(WARN_UNTIE)) {
cbdc8872 809 MAGIC * mg ;
33c27489 810 if (mg = SvTIED_mg(sv, how)) {
b9c39e73 811 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
cf2093f6 812 Perl_warner(aTHX_ WARN_UNTIE,
57def98f 813 "untie attempted while %"UVuf" inner references still exist",
cf2093f6 814 (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872
PP
815 }
816 }
817
33c27489 818 sv_unmagic(sv, how);
55497cff 819 RETPUSHYES;
a0d0e21e
LW
820}
821
c07a80fd
PP
822PP(pp_tied)
823{
4e35701f 824 djSP;
33c27489
GS
825 SV *sv = POPs;
826 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
827 MAGIC *mg;
c07a80fd 828
33c27489
GS
829 if (mg = SvTIED_mg(sv, how)) {
830 SV *osv = SvTIED_obj(sv, mg);
831 if (osv == mg->mg_obj)
832 osv = sv_mortalcopy(osv);
833 PUSHs(osv);
834 RETURN;
c07a80fd 835 }
c07a80fd
PP
836 RETPUSHUNDEF;
837}
838
a0d0e21e
LW
839PP(pp_dbmopen)
840{
4e35701f 841 djSP;
a0d0e21e
LW
842 HV *hv;
843 dPOPPOPssrl;
844 HV* stash;
845 GV *gv;
a0d0e21e
LW
846 SV *sv;
847
848 hv = (HV*)POPs;
849
3280af22 850 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW
851 sv_setpv(sv, "AnyDBM_File");
852 stash = gv_stashsv(sv, FALSE);
8ebc5c01 853 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 854 PUTBACK;
864dbfa3 855 require_pv("AnyDBM_File.pm");
a0d0e21e 856 SPAGAIN;
8ebc5c01 857 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 858 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW
859 }
860
57d3b86d 861 ENTER;
924508f0 862 PUSHMARK(SP);
6b05c17a 863
924508f0 864 EXTEND(SP, 5);
a0d0e21e
LW
865 PUSHs(sv);
866 PUSHs(left);
867 if (SvIV(right))
868 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
869 else
870 PUSHs(sv_2mortal(newSViv(O_RDWR)));
871 PUSHs(right);
57d3b86d 872 PUTBACK;
864dbfa3 873 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
874 SPAGAIN;
875
876 if (!sv_isobject(TOPs)) {
924508f0
GS
877 SP--;
878 PUSHMARK(SP);
a0d0e21e
LW
879 PUSHs(sv);
880 PUSHs(left);
881 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
882 PUSHs(right);
a0d0e21e 883 PUTBACK;
864dbfa3 884 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
885 SPAGAIN;
886 }
887
6b05c17a
NIS
888 if (sv_isobject(TOPs)) {
889 sv_unmagic((SV *) hv, 'P');
a0d0e21e 890 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 891 }
a0d0e21e
LW
892 LEAVE;
893 RETURN;
894}
895
896PP(pp_dbmclose)
897{
cea2e8a9 898 return pp_untie();
a0d0e21e
LW
899}
900
901PP(pp_sselect)
902{
4e35701f 903 djSP; dTARGET;
a0d0e21e
LW
904#ifdef HAS_SELECT
905 register I32 i;
906 register I32 j;
907 register char *s;
908 register SV *sv;
65202027 909 NV value;
a0d0e21e
LW
910 I32 maxlen = 0;
911 I32 nfound;
912 struct timeval timebuf;
913 struct timeval *tbuf = &timebuf;
914 I32 growsize;
915 char *fd_sets[4];
2d8e6c8d 916 STRLEN n_a;
a0d0e21e
LW
917#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
918 I32 masksize;
919 I32 offset;
920 I32 k;
921
922# if BYTEORDER & 0xf0000
923# define ORDERBYTE (0x88888888 - BYTEORDER)
924# else
925# define ORDERBYTE (0x4444 - BYTEORDER)
926# endif
927
928#endif
929
930 SP -= 4;
931 for (i = 1; i <= 3; i++) {
932 if (!SvPOK(SP[i]))
933 continue;
934 j = SvCUR(SP[i]);
935 if (maxlen < j)
936 maxlen = j;
937 }
938
5ff3f7a4 939/* little endians can use vecs directly */
a0d0e21e 940#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 941# if SELECT_MIN_BITS > 1
f2da832e
JH
942 /* If SELECT_MIN_BITS is greater than one we most probably will want
943 * to align the sizes with SELECT_MIN_BITS/8 because for example
944 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W
945 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
946 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 947 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 948# else
4633a7c4 949 growsize = sizeof(fd_set);
5ff3f7a4
GS
950# endif
951# else
952# ifdef NFDBITS
a0d0e21e 953
5ff3f7a4
GS
954# ifndef NBBY
955# define NBBY 8
956# endif
a0d0e21e
LW
957
958 masksize = NFDBITS / NBBY;
5ff3f7a4 959# else
a0d0e21e 960 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 961# endif
a0d0e21e
LW
962 growsize = maxlen + (masksize - (maxlen % masksize));
963 Zero(&fd_sets[0], 4, char*);
964#endif
965
966 sv = SP[4];
967 if (SvOK(sv)) {
968 value = SvNV(sv);
969 if (value < 0.0)
970 value = 0.0;
971 timebuf.tv_sec = (long)value;
65202027 972 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW
973 timebuf.tv_usec = (long)(value * 1000000.0);
974 }
975 else
976 tbuf = Null(struct timeval*);
977
978 for (i = 1; i <= 3; i++) {
979 sv = SP[i];
980 if (!SvOK(sv)) {
981 fd_sets[i] = 0;
982 continue;
983 }
984 else if (!SvPOK(sv))
2d8e6c8d 985 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW
986 j = SvLEN(sv);
987 if (j < growsize) {
988 Sv_Grow(sv, growsize);
a0d0e21e 989 }
c07a80fd
PP
990 j = SvCUR(sv);
991 s = SvPVX(sv) + j;
992 while (++j <= growsize) {
993 *s++ = '\0';
994 }
995
a0d0e21e
LW
996#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
997 s = SvPVX(sv);
998 New(403, fd_sets[i], growsize, char);
999 for (offset = 0; offset < growsize; offset += masksize) {
1000 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1001 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1002 }
1003#else
1004 fd_sets[i] = SvPVX(sv);
1005#endif
1006 }
1007
6ad3d225 1008 nfound = PerlSock_select(
a0d0e21e
LW
1009 maxlen * 8,
1010 (Select_fd_set_t) fd_sets[1],
1011 (Select_fd_set_t) fd_sets[2],
1012 (Select_fd_set_t) fd_sets[3],
1013 tbuf);
1014 for (i = 1; i <= 3; i++) {
1015 if (fd_sets[i]) {
1016 sv = SP[i];
1017#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1018 s = SvPVX(sv);
1019 for (offset = 0; offset < growsize; offset += masksize) {
1020 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1021 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1022 }
1023 Safefree(fd_sets[i]);
1024#endif
1025 SvSETMAGIC(sv);
1026 }
1027 }
1028
1029 PUSHi(nfound);
1030 if (GIMME == G_ARRAY && tbuf) {
65202027
DS
1031 value = (NV)(timebuf.tv_sec) +
1032 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1033 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW
1034 sv_setnv(sv, value);
1035 }
1036 RETURN;
1037#else
cea2e8a9 1038 DIE(aTHX_ "select not implemented");
a0d0e21e
LW
1039#endif
1040}
1041
4633a7c4 1042void
864dbfa3 1043Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1044{
11343788 1045 dTHR;
4633a7c4
LW
1046 if (gv)
1047 (void)SvREFCNT_inc(gv);
3280af22
NIS
1048 if (PL_defoutgv)
1049 SvREFCNT_dec(PL_defoutgv);
1050 PL_defoutgv = gv;
4633a7c4
LW
1051}
1052
a0d0e21e
LW
1053PP(pp_select)
1054{
4e35701f 1055 djSP; dTARGET;
4633a7c4
LW
1056 GV *newdefout, *egv;
1057 HV *hv;
1058
533c011a 1059 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1060
3280af22 1061 egv = GvEGV(PL_defoutgv);
4633a7c4 1062 if (!egv)
3280af22 1063 egv = PL_defoutgv;
4633a7c4
LW
1064 hv = GvSTASH(egv);
1065 if (! hv)
3280af22 1066 XPUSHs(&PL_sv_undef);
4633a7c4 1067 else {
cbdc8872 1068 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1069 if (gvp && *gvp == egv) {
3280af22 1070 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc
PP
1071 XPUSHTARG;
1072 }
1073 else {
1074 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1075 }
4633a7c4
LW
1076 }
1077
1078 if (newdefout) {
ded8aa31
GS
1079 if (!GvIO(newdefout))
1080 gv_IOadd(newdefout);
4633a7c4
LW
1081 setdefout(newdefout);
1082 }
1083
a0d0e21e
LW
1084 RETURN;
1085}
1086
1087PP(pp_getc)
1088{
4e35701f 1089 djSP; dTARGET;
a0d0e21e 1090 GV *gv;
2ae324a7 1091 MAGIC *mg;
a0d0e21e
LW
1092
1093 if (MAXARG <= 0)
3280af22 1094 gv = PL_stdingv;
a0d0e21e
LW
1095 else
1096 gv = (GV*)POPs;
2ae324a7 1097
33c27489 1098 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1099 I32 gimme = GIMME_V;
2ae324a7 1100 PUSHMARK(SP);
33c27489 1101 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7
PP
1102 PUTBACK;
1103 ENTER;
864dbfa3 1104 call_method("GETC", gimme);
2ae324a7
PP
1105 LEAVE;
1106 SPAGAIN;
54310121
PP
1107 if (gimme == G_SCALAR)
1108 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7
PP
1109 RETURN;
1110 }
9bc64814 1111 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1112 RETPUSHUNDEF;
bbce6d69 1113 TAINT;
a0d0e21e 1114 sv_setpv(TARG, " ");
9bc64814 1115 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW
1116 PUSHTARG;
1117 RETURN;
1118}
1119
1120PP(pp_read)
1121{
cea2e8a9 1122 return pp_sysread();
a0d0e21e
LW
1123}
1124
76e3520e 1125STATIC OP *
cea2e8a9 1126S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1127{
11343788 1128 dTHR;
c09156bb 1129 register PERL_CONTEXT *cx;
54310121 1130 I32 gimme = GIMME_V;
a0d0e21e
LW
1131 AV* padlist = CvPADLIST(cv);
1132 SV** svp = AvARRAY(padlist);
1133
1134 ENTER;
1135 SAVETMPS;
1136
1137 push_return(retop);
7766f137 1138 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1139 PUSHFORMAT(cx);
7766f137 1140 SAVEVPTR(PL_curpad);
3280af22 1141 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1142
4633a7c4 1143 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW
1144 return CvSTART(cv);
1145}
1146
1147PP(pp_enterwrite)
1148{
4e35701f 1149 djSP;
a0d0e21e
LW
1150 register GV *gv;
1151 register IO *io;
1152 GV *fgv;
1153 CV *cv;
1154
1155 if (MAXARG == 0)
3280af22 1156 gv = PL_defoutgv;
a0d0e21e
LW
1157 else {
1158 gv = (GV*)POPs;
1159 if (!gv)
3280af22 1160 gv = PL_defoutgv;
a0d0e21e
LW
1161 }
1162 EXTEND(SP, 1);
1163 io = GvIO(gv);
1164 if (!io) {
1165 RETPUSHNO;
1166 }
1167 if (IoFMT_GV(io))
1168 fgv = IoFMT_GV(io);
1169 else
1170 fgv = gv;
1171
1172 cv = GvFORM(fgv);
a0d0e21e
LW
1173 if (!cv) {
1174 if (fgv) {
748a9306 1175 SV *tmpsv = sv_newmortal();
aac0dd9a 1176 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1177 DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e 1178 }
cea2e8a9 1179 DIE(aTHX_ "Not a format reference");
a0d0e21e 1180 }
44a8e56a
PP
1181 if (CvCLONE(cv))
1182 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1183
44a8e56a 1184 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1185 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW
1186}
1187
1188PP(pp_leavewrite)
1189{
4e35701f 1190 djSP;
a0d0e21e
LW
1191 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1192 register IO *io = GvIOp(gv);
760ac839
LW
1193 PerlIO *ofp = IoOFP(io);
1194 PerlIO *fp;
a0d0e21e
LW
1195 SV **newsp;
1196 I32 gimme;
c09156bb 1197 register PERL_CONTEXT *cx;
a0d0e21e 1198
760ac839 1199 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS
1200 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1201 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1202 PL_formtarget != PL_toptarget)
a0d0e21e 1203 {
4633a7c4
LW
1204 GV *fgv;
1205 CV *cv;
a0d0e21e
LW
1206 if (!IoTOP_GV(io)) {
1207 GV *topgv;
46fc3d4c 1208 SV *topname;
a0d0e21e
LW
1209
1210 if (!IoTOP_NAME(io)) {
1211 if (!IoFMT_NAME(io))
1212 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1213 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1214 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1215 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1216 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1217 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW
1218 else
1219 IoTOP_NAME(io) = savepv("top");
1220 }
1221 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1222 if (!topgv || !GvFORM(topgv)) {
1223 IoLINES_LEFT(io) = 100000000;
1224 goto forget_top;
1225 }
1226 IoTOP_GV(io) = topgv;
1227 }
748a9306
LW
1228 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1229 I32 lines = IoLINES_LEFT(io);
3280af22 1230 char *s = SvPVX(PL_formtarget);
8e07c86e
AD
1231 if (lines <= 0) /* Yow, header didn't even fit!!! */
1232 goto forget_top;
748a9306
LW
1233 while (lines-- > 0) {
1234 s = strchr(s, '\n');
1235 if (!s)
1236 break;
1237 s++;
1238 }
1239 if (s) {
3280af22
NIS
1240 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1241 sv_chop(PL_formtarget, s);
1242 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1243 }
1244 }
a0d0e21e 1245 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1246 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW
1247 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1248 IoPAGE(io)++;
3280af22 1249 PL_formtarget = PL_toptarget;
748a9306 1250 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW
1251 fgv = IoTOP_GV(io);
1252 if (!fgv)
cea2e8a9 1253 DIE(aTHX_ "bad top format reference");
4633a7c4
LW
1254 cv = GvFORM(fgv);
1255 if (!cv) {
1256 SV *tmpsv = sv_newmortal();
aac0dd9a 1257 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1258 DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
4633a7c4 1259 }
44a8e56a
PP
1260 if (CvCLONE(cv))
1261 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1262 return doform(cv,gv,PL_op);
a0d0e21e
LW
1263 }
1264
1265 forget_top:
3280af22 1266 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW
1267 POPFORMAT(cx);
1268 LEAVE;
1269
1270 fp = IoOFP(io);
1271 if (!fp) {
599cee73 1272 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
69282e91
GS
1273 if (IoIFP(io)) {
1274 SV* sv = sv_newmortal();
1275 gv_efullname3(sv, gv, Nullch);
af8c498a
GS
1276 Perl_warner(aTHX_ WARN_IO,
1277 "Filehandle %s opened only for input",
1278 SvPV_nolen(sv));
69282e91 1279 }
599cee73 1280 else if (ckWARN(WARN_CLOSED))
69282e91 1281 report_closed_fh(gv, io, "write", "filehandle");
a0d0e21e 1282 }
3280af22 1283 PUSHs(&PL_sv_no);
a0d0e21e
LW
1284 }
1285 else {
3280af22 1286 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1287 if (ckWARN(WARN_IO))
cea2e8a9 1288 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1289 }
3280af22 1290 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1291 PerlIO_error(fp))
3280af22 1292 PUSHs(&PL_sv_no);
a0d0e21e 1293 else {
3280af22
NIS
1294 FmLINES(PL_formtarget) = 0;
1295 SvCUR_set(PL_formtarget, 0);
1296 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1297 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1298 (void)PerlIO_flush(fp);
3280af22 1299 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1300 }
1301 }
3280af22 1302 PL_formtarget = PL_bodytarget;
a0d0e21e
LW
1303 PUTBACK;
1304 return pop_return();
1305}
1306
1307PP(pp_prtf)
1308{
4e35701f 1309 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
1310 GV *gv;
1311 IO *io;
760ac839 1312 PerlIO *fp;
26db47c4 1313 SV *sv;
46fc3d4c 1314 MAGIC *mg;
2d8e6c8d 1315 STRLEN n_a;
a0d0e21e 1316
533c011a 1317 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1318 gv = (GV*)*++MARK;
1319 else
3280af22 1320 gv = PL_defoutgv;
46fc3d4c 1321
33c27489 1322 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1323 if (MARK == ORIGMARK) {
4352c267 1324 MEXTEND(SP, 1);
46fc3d4c
PP
1325 ++MARK;
1326 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1327 ++SP;
1328 }
1329 PUSHMARK(MARK - 1);
33c27489 1330 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c
PP
1331 PUTBACK;
1332 ENTER;
864dbfa3 1333 call_method("PRINTF", G_SCALAR);
46fc3d4c
PP
1334 LEAVE;
1335 SPAGAIN;
1336 MARK = ORIGMARK + 1;
1337 *MARK = *SP;
1338 SP = MARK;
1339 RETURN;
1340 }
1341
26db47c4 1342 sv = NEWSV(0,0);
a0d0e21e 1343 if (!(io = GvIO(gv))) {
599cee73 1344 if (ckWARN(WARN_UNOPENED)) {
af8c498a
GS
1345 gv_efullname3(sv, gv, Nullch);
1346 Perl_warner(aTHX_ WARN_UNOPENED,
1347 "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW
1348 }
1349 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1350 goto just_say_no;
1351 }
1352 else if (!(fp = IoOFP(io))) {
599cee73 1353 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
69282e91
GS
1354 if (IoIFP(io)) {
1355 gv_efullname3(sv, gv, Nullch);
af8c498a
GS
1356 Perl_warner(aTHX_ WARN_IO,
1357 "Filehandle %s opened only for input",
1358 SvPV(sv,n_a));
69282e91 1359 }
599cee73 1360 else if (ckWARN(WARN_CLOSED))
69282e91 1361 report_closed_fh(gv, io, "printf", "filehandle");
a0d0e21e 1362 }
748a9306 1363 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW
1364 goto just_say_no;
1365 }
1366 else {
1367 do_sprintf(sv, SP - MARK, MARK + 1);
1368 if (!do_print(sv, fp))
1369 goto just_say_no;
1370
1371 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1372 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1373 goto just_say_no;
1374 }
1375 SvREFCNT_dec(sv);
1376 SP = ORIGMARK;
3280af22 1377 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1378 RETURN;
1379
1380 just_say_no:
1381 SvREFCNT_dec(sv);
1382 SP = ORIGMARK;
3280af22 1383 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1384 RETURN;
1385}
1386
c07a80fd
PP
1387PP(pp_sysopen)
1388{
4e35701f 1389 djSP;
c07a80fd 1390 GV *gv;
c07a80fd
PP
1391 SV *sv;
1392 char *tmps;
1393 STRLEN len;
1394 int mode, perm;
1395
1396 if (MAXARG > 3)
1397 perm = POPi;
1398 else
1399 perm = 0666;
1400 mode = POPi;
1401 sv = POPs;
1402 gv = (GV *)POPs;
1403
4592e6ca
NIS
1404 /* Need TIEHANDLE method ? */
1405
c07a80fd
PP
1406 tmps = SvPV(sv, len);
1407 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1408 IoLINES(GvIOp(gv)) = 0;
3280af22 1409 PUSHs(&PL_sv_yes);
c07a80fd
PP
1410 }
1411 else {
3280af22 1412 PUSHs(&PL_sv_undef);
c07a80fd
PP
1413 }
1414 RETURN;
1415}
1416
a0d0e21e
LW
1417PP(pp_sysread)
1418{
4e35701f 1419 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1420 int offset;
1421 GV *gv;
1422 IO *io;
1423 char *buffer;
5b54f415 1424 SSize_t length;
1e422769 1425 Sock_size_t bufsize;
748a9306 1426 SV *bufsv;
a0d0e21e 1427 STRLEN blen;
2ae324a7 1428 MAGIC *mg;
a0d0e21e
LW
1429
1430 gv = (GV*)*++MARK;
533c011a 1431 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1432 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1433 {
2ae324a7
PP
1434 SV *sv;
1435
1436 PUSHMARK(MARK-1);
33c27489 1437 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1438 ENTER;
864dbfa3 1439 call_method("READ", G_SCALAR);
2ae324a7
PP
1440 LEAVE;
1441 SPAGAIN;
1442 sv = POPs;
1443 SP = ORIGMARK;
1444 PUSHs(sv);
1445 RETURN;
1446 }
1447
a0d0e21e
LW
1448 if (!gv)
1449 goto say_undef;
748a9306 1450 bufsv = *++MARK;
ff68c719
PP
1451 if (! SvOK(bufsv))
1452 sv_setpvn(bufsv, "", 0);
748a9306 1453 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW
1454 length = SvIVx(*++MARK);
1455 if (length < 0)
cea2e8a9 1456 DIE(aTHX_ "Negative length");
748a9306 1457 SETERRNO(0,0);
a0d0e21e
LW
1458 if (MARK < SP)
1459 offset = SvIVx(*++MARK);
1460 else
1461 offset = 0;
1462 io = GvIO(gv);
1463 if (!io || !IoIFP(io))
1464 goto say_undef;
1465#ifdef HAS_SOCKET
533c011a 1466 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1467 char namebuf[MAXPATHLEN];
eec2d3df 1468#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH
1469 bufsize = sizeof (struct sockaddr_in);
1470#else
46fc3d4c 1471 bufsize = sizeof namebuf;
490ab354 1472#endif
abf95952
IZ
1473#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1474 if (bufsize >= 256)
1475 bufsize = 255;
1476#endif
626727d5
GS
1477#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1478 if (bufsize >= 256)
1479 bufsize = 255;
1480#endif
748a9306 1481 buffer = SvGROW(bufsv, length+1);
bbce6d69 1482 /* 'offset' means 'flags' here */
6ad3d225 1483 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1484 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1485 if (length < 0)
1486 RETPUSHUNDEF;
748a9306
LW
1487 SvCUR_set(bufsv, length);
1488 *SvEND(bufsv) = '\0';
1489 (void)SvPOK_only(bufsv);
1490 SvSETMAGIC(bufsv);
aac0dd9a 1491 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1492 if (!(IoFLAGS(io) & IOf_UNTAINT))
1493 SvTAINTED_on(bufsv);
a0d0e21e 1494 SP = ORIGMARK;
46fc3d4c 1495 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1496 PUSHs(TARG);
1497 RETURN;
1498 }
1499#else
911d147d 1500 if (PL_op->op_type == OP_RECV)
cea2e8a9 1501 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1502#endif
bbce6d69
PP
1503 if (offset < 0) {
1504 if (-offset > blen)
cea2e8a9 1505 DIE(aTHX_ "Offset outside string");
bbce6d69
PP
1506 offset += blen;
1507 }
cd52b7b2 1508 bufsize = SvCUR(bufsv);
748a9306 1509 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2
PP
1510 if (offset > bufsize) { /* Zero any newly allocated space */
1511 Zero(buffer+bufsize, offset-bufsize, char);
1512 }
533c011a 1513 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS
1514#ifdef PERL_SOCK_SYSREAD_IS_RECV
1515 if (IoTYPE(io) == 's') {
1516 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1517 buffer+offset, length, 0);
1518 }
1519 else
1520#endif
1521 {
1522 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1523 buffer+offset, length);
1524 }
a0d0e21e
LW
1525 }
1526 else
1527#ifdef HAS_SOCKET__bad_code_maybe
1528 if (IoTYPE(io) == 's') {
46fc3d4c 1529 char namebuf[MAXPATHLEN];
490ab354
JH
1530#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1531 bufsize = sizeof (struct sockaddr_in);
1532#else
46fc3d4c 1533 bufsize = sizeof namebuf;
490ab354 1534#endif
6ad3d225 1535 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1536 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1537 }
1538 else
1539#endif
3b02c43c 1540 {
760ac839 1541 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1542 /* fread() returns 0 on both error and EOF */
5c7a8c78 1543 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS
1544 length = -1;
1545 }
af8c498a 1546 if (length < 0) {
767a6a26
PM
1547 if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
1548 || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
af8c498a
GS
1549 {
1550 SV* sv = sv_newmortal();
1551 gv_efullname3(sv, gv, Nullch);
1552 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1553 SvPV_nolen(sv));
1554 }
a0d0e21e 1555 goto say_undef;
af8c498a 1556 }
748a9306
LW
1557 SvCUR_set(bufsv, length+offset);
1558 *SvEND(bufsv) = '\0';
1559 (void)SvPOK_only(bufsv);
1560 SvSETMAGIC(bufsv);
aac0dd9a 1561 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1562 if (!(IoFLAGS(io) & IOf_UNTAINT))
1563 SvTAINTED_on(bufsv);
a0d0e21e
LW
1564 SP = ORIGMARK;
1565 PUSHi(length);
1566 RETURN;
1567
1568 say_undef:
1569 SP = ORIGMARK;
1570 RETPUSHUNDEF;
1571}
1572
1573PP(pp_syswrite)
1574{
092bebab
JH
1575 djSP;
1576 int items = (SP - PL_stack_base) - TOPMARK;
1577 if (items == 2) {
9f089d78 1578 SV *sv;
092bebab 1579 EXTEND(SP, 1);
9f089d78
SB
1580 sv = sv_2mortal(newSViv(sv_len(*SP)));
1581 PUSHs(sv);
092bebab
JH
1582 PUTBACK;
1583 }
cea2e8a9 1584 return pp_send();
a0d0e21e
LW
1585}
1586
1587PP(pp_send)
1588{
4e35701f 1589 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1590 GV *gv;
1591 IO *io;
1eeb0f31 1592 Off_t offset;
748a9306 1593 SV *bufsv;
a0d0e21e 1594 char *buffer;
1eeb0f31 1595 Off_t length;
a0d0e21e 1596 STRLEN blen;
1d603a67 1597 MAGIC *mg;
a0d0e21e
LW
1598
1599 gv = (GV*)*++MARK;
33c27489 1600 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB
1601 SV *sv;
1602
1603 PUSHMARK(MARK-1);
33c27489 1604 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1605 ENTER;
864dbfa3 1606 call_method("WRITE", G_SCALAR);
1d603a67
GB
1607 LEAVE;
1608 SPAGAIN;
1609 sv = POPs;
1610 SP = ORIGMARK;
1611 PUSHs(sv);
1612 RETURN;
1613 }
a0d0e21e
LW
1614 if (!gv)
1615 goto say_undef;
748a9306
LW
1616 bufsv = *++MARK;
1617 buffer = SvPV(bufsv, blen);
1eeb0f31
JH
1618#if Off_t_SIZE > IVSIZE
1619 length = SvNVx(*++MARK);
1620#else
a0d0e21e 1621 length = SvIVx(*++MARK);
1eeb0f31 1622#endif
a0d0e21e 1623 if (length < 0)
cea2e8a9 1624 DIE(aTHX_ "Negative length");
748a9306 1625 SETERRNO(0,0);
a0d0e21e
LW
1626 io = GvIO(gv);
1627 if (!io || !IoIFP(io)) {
1628 length = -1;
599cee73 1629 if (ckWARN(WARN_CLOSED)) {
533c011a 1630 if (PL_op->op_type == OP_SYSWRITE)
69282e91 1631 report_closed_fh(gv, io, "syswrite", "filehandle");
a0d0e21e 1632 else
69282e91 1633 report_closed_fh(gv, io, "send", "socket");
a0d0e21e
LW
1634 }
1635 }
533c011a 1636 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1637 if (MARK < SP) {
1eeb0f31
JH
1638#if Off_t_SIZE > IVSIZE
1639 offset = SvNVx(*++MARK);
1640#else
a0d0e21e 1641 offset = SvIVx(*++MARK);
1eeb0f31 1642#endif
bbce6d69
PP
1643 if (offset < 0) {
1644 if (-offset > blen)
cea2e8a9 1645 DIE(aTHX_ "Offset outside string");
bbce6d69 1646 offset += blen;
fb73857a 1647 } else if (offset >= blen && blen > 0)
cea2e8a9 1648 DIE(aTHX_ "Offset outside string");
bbce6d69 1649 } else
a0d0e21e
LW
1650 offset = 0;
1651 if (length > blen - offset)
1652 length = blen - offset;
a7092146
GS
1653#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1654 if (IoTYPE(io) == 's') {
1655 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1656 buffer+offset, length, 0);
1657 }
1658 else
1659#endif
1660 {
94e4c244 1661 /* See the note at doio.c:do_print about filesize limits. --jhi */
a7092146
GS
1662 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1663 buffer+offset, length);
1664 }
a0d0e21e
LW
1665 }
1666#ifdef HAS_SOCKET
1667 else if (SP > MARK) {
1668 char *sockbuf;
1669 STRLEN mlen;
1670 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1671 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW
1672 (struct sockaddr *)sockbuf, mlen);
1673 }
1674 else
6ad3d225 1675 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1676
a0d0e21e
LW
1677#else
1678 else
cea2e8a9 1679 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e
LW
1680#endif
1681 if (length < 0)
1682 goto say_undef;
1683 SP = ORIGMARK;
1684 PUSHi(length);
1685 RETURN;
1686
1687 say_undef:
1688 SP = ORIGMARK;
1689 RETPUSHUNDEF;
1690}
1691
1692PP(pp_recv)
1693{
cea2e8a9 1694 return pp_sysread();
a0d0e21e
LW
1695}
1696
1697PP(pp_eof)
1698{
4e35701f 1699 djSP;
a0d0e21e 1700 GV *gv;
4592e6ca 1701 MAGIC *mg;
a0d0e21e 1702
db7ec623
GS
1703 if (MAXARG <= 0) {
1704 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1705 IO *io;
1706 gv = PL_last_in_gv = PL_argvgv;
1707 io = GvIO(gv);
1708 if (io && !IoIFP(io)) {
1709 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1710 IoLINES(io) = 0;
1711 IoFLAGS(io) &= ~IOf_START;
1712 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1713 sv_setpvn(GvSV(gv), "-", 1);
1714 SvSETMAGIC(GvSV(gv));
1715 }
1716 else if (!nextargv(gv))
1717 RETPUSHYES;
1718 }
1719 }
1720 else
1721 gv = PL_last_in_gv; /* eof */
1722 }
a0d0e21e 1723 else
db7ec623 1724 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca
NIS
1725
1726 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1727 PUSHMARK(SP);
1728 XPUSHs(SvTIED_obj((SV*)gv, mg));
1729 PUTBACK;
1730 ENTER;
864dbfa3 1731 call_method("EOF", G_SCALAR);
4592e6ca
NIS
1732 LEAVE;
1733 SPAGAIN;
1734 RETURN;
1735 }
1736
54310121 1737 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW
1738 RETURN;
1739}
1740
1741PP(pp_tell)
1742{
4e35701f 1743 djSP; dTARGET;
4592e6ca
NIS
1744 GV *gv;
1745 MAGIC *mg;
a0d0e21e
LW
1746
1747 if (MAXARG <= 0)
3280af22 1748 gv = PL_last_in_gv;
a0d0e21e 1749 else
3280af22 1750 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1751
1752 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1753 PUSHMARK(SP);
1754 XPUSHs(SvTIED_obj((SV*)gv, mg));
1755 PUTBACK;
1756 ENTER;
864dbfa3 1757 call_method("TELL", G_SCALAR);
4592e6ca
NIS
1758 LEAVE;
1759 SPAGAIN;
1760 RETURN;
1761 }
1762
e0a10278
JH
1763#if LSEEKSIZE > IVSIZE
1764 PUSHn( do_tell(gv) );
1765#else
a0d0e21e 1766 PUSHi( do_tell(gv) );
e0a10278 1767#endif
a0d0e21e
LW
1768 RETURN;
1769}
1770
1771PP(pp_seek)
1772{
cea2e8a9 1773 return pp_sysseek();
137443ea
PP
1774}
1775
1776PP(pp_sysseek)
1777{
4e35701f 1778 djSP;
a0d0e21e
LW
1779 GV *gv;
1780 int whence = POPi;
e0a10278
JH
1781#if LSEEKSIZE > IVSIZE
1782 Off_t offset = (Off_t)SvNVx(POPs);
1783#else
d9b3e12d 1784 Off_t offset = (Off_t)SvIVx(POPs);
e0a10278 1785#endif
4592e6ca 1786 MAGIC *mg;
a0d0e21e 1787
3280af22 1788 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS
1789
1790 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1791 PUSHMARK(SP);
1792 XPUSHs(SvTIED_obj((SV*)gv, mg));
3dc6ede7
JH
1793#if LSEEKSIZE > IVSIZE
1794 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1795#else
4592e6ca 1796 XPUSHs(sv_2mortal(newSViv((IV) offset)));
3dc6ede7 1797#endif
4592e6ca
NIS
1798 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1799 PUTBACK;
1800 ENTER;
864dbfa3 1801 call_method("SEEK", G_SCALAR);
4592e6ca
NIS
1802 LEAVE;
1803 SPAGAIN;
1804 RETURN;
1805 }
1806
533c011a 1807 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
1808 PUSHs(boolSV(do_seek(gv, offset, whence)));
1809 else {
97cc44eb 1810 Off_t n = do_sysseek(gv, offset, whence);
e0a10278
JH
1811 if (n < 0)
1812 PUSHs(&PL_sv_undef);
1813 else {
1814 SV* sv = n ?
1815#if LSEEKSIZE > IVSIZE
1816 newSVnv((NV)n)
1817#else
1818 newSViv((IV)n)
1819#endif
1820 : newSVpvn(zero_but_true, ZBTLEN);
1821 PUSHs(sv_2mortal(sv));
1822 }
8903cb82 1823 }
a0d0e21e
LW
1824 RETURN;
1825}
1826
1827PP(pp_truncate)
1828{
4e35701f 1829 djSP;
a0d0e21e
LW
1830 Off_t len = (Off_t)POPn;
1831 int result = 1;
1832 GV *tmpgv;
2d8e6c8d 1833 STRLEN n_a;
a0d0e21e 1834
748a9306 1835 SETERRNO(0,0);
5d94fbed 1836#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1837 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1838 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1839 do_ftruncate:
1e422769 1840 TAINT_PROPER("truncate");
2f3b6ae4
GS
1841 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1842 result = 0;
1843 else {
1844 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 1845#ifdef HAS_TRUNCATE
2f3b6ae4 1846 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1847#else
2f3b6ae4 1848 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1849#endif
2f3b6ae4
GS
1850 result = 0;
1851 }
a0d0e21e
LW
1852 }
1853 else {
cbdc8872 1854 SV *sv = POPs;
1e422769 1855 char *name;
2d8e6c8d 1856 STRLEN n_a;
1e422769 1857
cbdc8872
PP
1858 if (SvTYPE(sv) == SVt_PVGV) {
1859 tmpgv = (GV*)sv; /* *main::FRED for example */
1860 goto do_ftruncate;
1861 }
1862 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1863 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1864 goto do_ftruncate;
1865 }
1e422769 1866
2d8e6c8d 1867 name = SvPV(sv, n_a);
1e422769 1868 TAINT_PROPER("truncate");
cbdc8872 1869#ifdef HAS_TRUNCATE
1e422769 1870 if (truncate(name, len) < 0)
a0d0e21e 1871 result = 0;
cbdc8872
PP
1872#else
1873 {
1874 int tmpfd;
6ad3d225 1875 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1876 result = 0;
cbdc8872
PP
1877 else {
1878 if (my_chsize(tmpfd, len) < 0)
1879 result = 0;
6ad3d225 1880 PerlLIO_close(tmpfd);
cbdc8872 1881 }
a0d0e21e 1882 }
a0d0e21e 1883#endif
cbdc8872 1884 }
a0d0e21e
LW
1885
1886 if (result)
1887 RETPUSHYES;
1888 if (!errno)
748a9306 1889 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1890 RETPUSHUNDEF;
1891#else
cea2e8a9 1892 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW
1893#endif
1894}
1895
1896PP(pp_fcntl)
1897{
cea2e8a9 1898 return pp_ioctl();
a0d0e21e
LW
1899}
1900
1901PP(pp_ioctl)
1902{
4e35701f 1903 djSP; dTARGET;
748a9306 1904 SV *argsv = POPs;
a0d0e21e 1905 unsigned int func = U_I(POPn);
533c011a 1906 int optype = PL_op->op_type;
a0d0e21e 1907 char *s;
324aa91a 1908 IV retval;
a0d0e21e
LW
1909 GV *gv = (GV*)POPs;
1910 IO *io = GvIOn(gv);
1911
748a9306
LW
1912 if (!io || !argsv || !IoIFP(io)) {
1913 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW
1914 RETPUSHUNDEF;
1915 }
1916
748a9306 1917 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1918 STRLEN len;
324aa91a 1919 STRLEN need;
748a9306 1920 s = SvPV_force(argsv, len);
324aa91a
HF
1921 need = IOCPARM_LEN(func);
1922 if (len < need) {
1923 s = Sv_Grow(argsv, need + 1);
1924 SvCUR_set(argsv, need);
a0d0e21e
LW
1925 }
1926
748a9306 1927 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
1928 }
1929 else {
748a9306 1930 retval = SvIV(argsv);
56431972 1931 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW
1932 }
1933
1934 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1935
1936 if (optype == OP_IOCTL)
1937#ifdef HAS_IOCTL
76e3520e 1938 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 1939#else
cea2e8a9 1940 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW
1941#endif
1942 else
55497cff
PP
1943#ifdef HAS_FCNTL
1944#if defined(OS2) && defined(__EMX__)
760ac839 1945 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1946#else
760ac839 1947 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff
PP
1948#endif
1949#else
cea2e8a9 1950 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW
1951#endif
1952
748a9306
LW
1953 if (SvPOK(argsv)) {
1954 if (s[SvCUR(argsv)] != 17)
cea2e8a9 1955 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1956 PL_op_name[optype]);
748a9306
LW
1957 s[SvCUR(argsv)] = 0; /* put our null back */
1958 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
1959 }
1960
1961 if (retval == -1)
1962 RETPUSHUNDEF;
1963 if (retval != 0) {
1964 PUSHi(retval);
1965 }
1966 else {
8903cb82 1967 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW
1968 }
1969 RETURN;
1970}
1971
1972PP(pp_flock)
1973{
4e35701f 1974 djSP; dTARGET;
a0d0e21e
LW
1975 I32 value;
1976 int argtype;
1977 GV *gv;
760ac839 1978 PerlIO *fp;
16d20bd9 1979
ff68c719 1980#ifdef FLOCK
a0d0e21e
LW
1981 argtype = POPi;
1982 if (MAXARG <= 0)
3280af22 1983 gv = PL_last_in_gv;
a0d0e21e
LW
1984 else
1985 gv = (GV*)POPs;
1986 if (gv && GvIO(gv))
1987 fp = IoIFP(GvIOp(gv));
1988 else
1989 fp = Nullfp;
1990 if (fp) {
68dc0745 1991 (void)PerlIO_flush(fp);
76e3520e 1992 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 1993 }
69282e91 1994 else {
a0d0e21e 1995 value = 0;
69282e91
GS
1996 SETERRNO(EBADF,RMS$_IFI);
1997 if (ckWARN(WARN_CLOSED))
1998 report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
1999 }
a0d0e21e
LW
2000 PUSHi(value);
2001 RETURN;
2002#else
cea2e8a9 2003 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW
2004#endif
2005}
2006
2007/* Sockets. */
2008
2009PP(pp_socket)
2010{
4e35701f 2011 djSP;
a0d0e21e
LW
2012#ifdef HAS_SOCKET
2013 GV *gv;
2014 register IO *io;
2015 int protocol = POPi;
2016 int type = POPi;
2017 int domain = POPi;
2018 int fd;
2019
2020 gv = (GV*)POPs;
2021
2022 if (!gv) {
748a9306 2023 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW
2024 RETPUSHUNDEF;
2025 }
2026
2027 io = GvIOn(gv);
2028 if (IoIFP(io))
2029 do_close(gv, FALSE);
2030
2031 TAINT_PROPER("socket");
6ad3d225 2032 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW
2033 if (fd < 0)
2034 RETPUSHUNDEF;
760ac839
LW
2035 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2036 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW
2037 IoTYPE(io) = 's';
2038 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
2039 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2040 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2041 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
2042 RETPUSHUNDEF;
2043 }
8d2a6795
GS
2044#if defined(HAS_FCNTL) && defined(F_SETFD)
2045 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2046#endif
a0d0e21e
LW
2047
2048 RETPUSHYES;
2049#else
cea2e8a9 2050 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW
2051#endif
2052}
2053
2054PP(pp_sockpair)
2055{
4e35701f 2056 djSP;
a0d0e21e
LW
2057#ifdef HAS_SOCKETPAIR
2058 GV *gv1;
2059 GV *gv2;
2060 register IO *io1;
2061 register IO *io2;
2062 int protocol = POPi;
2063 int type = POPi;
2064 int domain = POPi;
2065 int fd[2];
2066
2067 gv2 = (GV*)POPs;
2068 gv1 = (GV*)POPs;
2069 if (!gv1 || !gv2)
2070 RETPUSHUNDEF;
2071
2072 io1 = GvIOn(gv1);
2073 io2 = GvIOn(gv2);
2074 if (IoIFP(io1))
2075 do_close(gv1, FALSE);
2076 if (IoIFP(io2))
2077 do_close(gv2, FALSE);
2078
2079 TAINT_PROPER("socketpair");
6ad3d225 2080 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2081 RETPUSHUNDEF;
760ac839
LW
2082 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2083 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2084 IoTYPE(io1) = 's';
760ac839
LW
2085 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2086 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
2087 IoTYPE(io2) = 's';
2088 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW
2089 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2090 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2091 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW
2092 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2093 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2094 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW
2095 RETPUSHUNDEF;
2096 }
8d2a6795
GS
2097#if defined(HAS_FCNTL) && defined(F_SETFD)
2098 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2099 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2100#endif
a0d0e21e
LW
2101
2102 RETPUSHYES;
2103#else
cea2e8a9 2104 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW
2105#endif
2106}
2107
2108PP(pp_bind)
2109{
4e35701f 2110 djSP;
a0d0e21e 2111#ifdef HAS_SOCKET
eec2d3df
GS
2112#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2113 extern GETPRIVMODE();
2114 extern GETUSERMODE();
2115#endif
748a9306 2116 SV *addrsv = POPs;
a0d0e21e
LW
2117 char *addr;
2118 GV *gv = (GV*)POPs;
2119 register IO *io = GvIOn(gv);
2120 STRLEN len;
eec2d3df
GS
2121 int bind_ok = 0;
2122#ifdef MPE
2123 int mpeprivmode = 0;
2124#endif
a0d0e21e
LW
2125
2126 if (!io || !IoIFP(io))
2127 goto nuts;
2128
748a9306 2129 addr = SvPV(addrsv, len);
a0d0e21e 2130 TAINT_PROPER("bind");
eec2d3df
GS
2131#ifdef MPE /* Deal with MPE bind() peculiarities */
2132 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2133 /* The address *MUST* stupidly be zero. */
2134 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2135 /* PRIV mode is required to bind() to ports < 1024. */
2136 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2137 ((struct sockaddr_in *)addr)->sin_port > 0) {
2138 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2139 mpeprivmode = 1;
2140 }
2141 }
2142#endif /* MPE */
2143 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2144 (struct sockaddr *)addr, len) >= 0)
2145 bind_ok = 1;
2146
2147#ifdef MPE /* Switch back to USER mode */
2148 if (mpeprivmode)
2149 GETUSERMODE();
2150#endif /* MPE */
2151
2152 if (bind_ok)
a0d0e21e
LW
2153 RETPUSHYES;
2154 else
2155 RETPUSHUNDEF;
2156
2157nuts:
599cee73 2158 if (ckWARN(WARN_CLOSED))
69282e91 2159 report_closed_fh(gv, io, "bind", "socket");
748a9306 2160 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2161 RETPUSHUNDEF;
2162#else
cea2e8a9 2163 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW
2164#endif
2165}
2166
2167PP(pp_connect)
2168{
4e35701f 2169 djSP;
a0d0e21e 2170#ifdef HAS_SOCKET
748a9306 2171 SV *addrsv = POPs;
a0d0e21e
LW
2172 char *addr;
2173 GV *gv = (GV*)POPs;
2174 register IO *io = GvIOn(gv);
2175 STRLEN len;
2176
2177 if (!io || !IoIFP(io))
2178 goto nuts;
2179
748a9306 2180 addr = SvPV(addrsv, len);
a0d0e21e 2181 TAINT_PROPER("connect");
6ad3d225 2182 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW
2183 RETPUSHYES;
2184 else
2185 RETPUSHUNDEF;
2186
2187nuts:
599cee73 2188 if (ckWARN(WARN_CLOSED))
69282e91 2189 report_closed_fh(gv, io, "connect", "socket");
748a9306 2190 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2191 RETPUSHUNDEF;
2192#else
cea2e8a9 2193 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW
2194#endif
2195}
2196
2197PP(pp_listen)
2198{
4e35701f 2199 djSP;
a0d0e21e
LW
2200#ifdef HAS_SOCKET
2201 int backlog = POPi;
2202 GV *gv = (GV*)POPs;
2203 register IO *io = GvIOn(gv);
2204
2205 if (!io || !IoIFP(io))
2206 goto nuts;
2207
6ad3d225 2208 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW
2209 RETPUSHYES;
2210 else
2211 RETPUSHUNDEF;
2212
2213nuts:
599cee73 2214 if (ckWARN(WARN_CLOSED))
69282e91 2215 report_closed_fh(gv, io, "listen", "socket");
748a9306 2216 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2217 RETPUSHUNDEF;
2218#else
cea2e8a9 2219 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW
2220#endif
2221}
2222
2223PP(pp_accept)
2224{
4e35701f 2225 djSP; dTARGET;
a0d0e21e
LW
2226#ifdef HAS_SOCKET
2227 GV *ngv;
2228 GV *ggv;
2229 register IO *nstio;
2230 register IO *gstio;
4633a7c4 2231 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2232 Sock_size_t len = sizeof saddr;
a0d0e21e
LW
2233 int fd;
2234
2235 ggv = (GV*)POPs;
2236 ngv = (GV*)POPs;
2237
2238 if (!ngv)
2239 goto badexit;
2240 if (!ggv)
2241 goto nuts;
2242
2243 gstio = GvIO(ggv);
2244 if (!gstio || !IoIFP(gstio))
2245 goto nuts;
2246
2247 nstio = GvIOn(ngv);
2248 if (IoIFP(nstio))
2249 do_close(ngv, FALSE);
2250
6ad3d225 2251 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW
2252 if (fd < 0)
2253 goto badexit;
760ac839
LW
2254 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2255 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW
2256 IoTYPE(nstio) = 's';
2257 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW
2258 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2259 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2260 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW
2261 goto badexit;
2262 }
8d2a6795
GS
2263#if defined(HAS_FCNTL) && defined(F_SETFD)
2264 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2265#endif
a0d0e21e 2266
748a9306 2267 PUSHp((char *)&saddr, len);
a0d0e21e
LW
2268 RETURN;
2269
2270nuts:
599cee73 2271 if (ckWARN(WARN_CLOSED))
69282e91 2272 report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
748a9306 2273 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2274
2275badexit:
2276 RETPUSHUNDEF;
2277
2278#else
cea2e8a9 2279 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW
2280#endif
2281}
2282
2283PP(pp_shutdown)
2284{
4e35701f 2285 djSP; dTARGET;
a0d0e21e
LW
2286#ifdef HAS_SOCKET
2287 int how = POPi;
2288 GV *gv = (GV*)POPs;
2289 register IO *io = GvIOn(gv);
2290
2291 if (!io || !IoIFP(io))
2292 goto nuts;
2293
6ad3d225 2294 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW
2295 RETURN;
2296
2297nuts:
599cee73 2298 if (ckWARN(WARN_CLOSED))
69282e91 2299 report_closed_fh(gv, io, "shutdown", "socket");
748a9306 2300 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2301 RETPUSHUNDEF;
2302#else
cea2e8a9 2303 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW
2304#endif
2305}
2306
2307PP(pp_gsockopt)
2308{
2309#ifdef HAS_SOCKET
cea2e8a9 2310 return pp_ssockopt();
a0d0e21e 2311#else
cea2e8a9 2312 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW
2313#endif
2314}
2315
2316PP(pp_ssockopt)
2317{
4e35701f 2318 djSP;
a0d0e21e 2319#ifdef HAS_SOCKET
533c011a 2320 int optype = PL_op->op_type;
a0d0e21e
LW
2321 SV *sv;
2322 int fd;
2323 unsigned int optname;
2324 unsigned int lvl;
2325 GV *gv;
2326 register IO *io;
1e422769 2327 Sock_size_t len;
a0d0e21e
LW
2328
2329 if (optype == OP_GSOCKOPT)
2330 sv = sv_2mortal(NEWSV(22, 257));
2331 else
2332 sv = POPs;
2333 optname = (unsigned int) POPi;
2334 lvl = (unsigned int) POPi;
2335
2336 gv = (GV*)POPs;
2337 io = GvIOn(gv);
2338 if (!io || !IoIFP(io))
2339 goto nuts;
2340
760ac839 2341 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2342 switch (optype) {
2343 case OP_GSOCKOPT:
748a9306 2344 SvGROW(sv, 257);
a0d0e21e 2345 (void)SvPOK_only(sv);
748a9306
LW
2346 SvCUR_set(sv,256);
2347 *SvEND(sv) ='\0';
1e422769 2348 len = SvCUR(sv);
6ad3d225 2349 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2350 goto nuts2;
1e422769 2351 SvCUR_set(sv, len);
748a9306 2352 *SvEND(sv) ='\0';
a0d0e21e
LW
2353 PUSHs(sv);
2354 break;
2355 case OP_SSOCKOPT: {
1e422769
PP
2356 char *buf;
2357 int aint;
2358 if (SvPOKp(sv)) {
2d8e6c8d
GS
2359 STRLEN l;
2360 buf = SvPV(sv, l);
2361 len = l;
1e422769 2362 }
56ee1660 2363 else {
a0d0e21e
LW
2364 aint = (int)SvIV(sv);
2365 buf = (char*)&aint;
2366 len = sizeof(int);
2367 }
6ad3d225 2368 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2369 goto nuts2;
3280af22 2370 PUSHs(&PL_sv_yes);
a0d0e21e
LW
2371 }
2372 break;
2373 }
2374 RETURN;
2375
2376nuts:
599cee73 2377 if (ckWARN(WARN_CLOSED))
69282e91
GS
2378 report_closed_fh(gv, io,
2379 optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
2380 "socket");
748a9306 2381 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2382nuts2:
2383 RETPUSHUNDEF;
2384
2385#else
cea2e8a9 2386 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW
2387#endif
2388}
2389
2390PP(pp_getsockname)
2391{
2392#ifdef HAS_SOCKET
cea2e8a9 2393 return pp_getpeername();
a0d0e21e 2394#else
cea2e8a9 2395 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW
2396#endif
2397}
2398
2399PP(pp_getpeername)
2400{
4e35701f 2401 djSP;
a0d0e21e 2402#ifdef HAS_SOCKET
533c011a 2403 int optype = PL_op->op_type;
a0d0e21e
LW
2404 SV *sv;
2405 int fd;
2406 GV *gv = (GV*)POPs;
2407 register IO *io = GvIOn(gv);
1e422769 2408 Sock_size_t len;
a0d0e21e
LW
2409
2410 if (!io || !IoIFP(io))
2411 goto nuts;
2412
2413 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2414 (void)SvPOK_only(sv);
1e422769
PP
2415 len = 256;
2416 SvCUR_set(sv, len);
748a9306 2417 *SvEND(sv) ='\0';
760ac839 2418 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2419 switch (optype) {
2420 case OP_GETSOCKNAME:
6ad3d225 2421 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW
2422 goto nuts2;
2423 break;
2424 case OP_GETPEERNAME:
6ad3d225 2425 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2426 goto nuts2;
490ab354
JH
2427#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2428 {
2429 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2430 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2431 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2432 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2433 sizeof(u_short) + sizeof(struct in_addr))) {
2434 goto nuts2;
2435 }
2436 }
2437#endif
a0d0e21e
LW
2438 break;
2439 }
13826f2c
CS
2440#ifdef BOGUS_GETNAME_RETURN
2441 /* Interactive Unix, getpeername() and getsockname()
2442 does not return valid namelen */
1e422769
PP
2443 if (len == BOGUS_GETNAME_RETURN)
2444 len = sizeof(struct sockaddr);
13826f2c 2445#endif
1e422769 2446 SvCUR_set(sv, len);
748a9306 2447 *SvEND(sv) ='\0';
a0d0e21e
LW
2448 PUSHs(sv);
2449 RETURN;
2450
2451nuts:
599cee73 2452 if (ckWARN(WARN_CLOSED))
69282e91
GS
2453 report_closed_fh(gv, io,
2454 optype == OP_GETSOCKNAME ? "getsockname"
2455 : "getpeername",
2456 "socket");
748a9306 2457 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2458nuts2:
2459 RETPUSHUNDEF;
2460
2461#else
cea2e8a9 2462 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW
2463#endif
2464}
2465
2466/* Stat calls. */
2467
2468PP(pp_lstat)
2469{
cea2e8a9 2470 return pp_stat();
a0d0e21e
LW
2471}
2472
2473PP(pp_stat)
2474{
4e35701f 2475 djSP;
a0d0e21e 2476 GV *tmpgv;
54310121 2477 I32 gimme;
a0d0e21e 2478 I32 max = 13;
2d8e6c8d 2479 STRLEN n_a;
a0d0e21e 2480
533c011a 2481 if (PL_op->op_flags & OPf_REF) {
638eceb6 2482 tmpgv = cGVOP_gv;
748a9306 2483 do_fstat:
3280af22
NIS
2484 if (tmpgv != PL_defgv) {
2485 PL_laststype = OP_STAT;
2486 PL_statgv = tmpgv;
2487 sv_setpv(PL_statname, "");
2488 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2489 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2490 }
3280af22 2491 if (PL_laststatval < 0)
a0d0e21e
LW
2492 max = 0;
2493 }
2494 else {
748a9306
LW
2495 SV* sv = POPs;
2496 if (SvTYPE(sv) == SVt_PVGV) {
2497 tmpgv = (GV*)sv;
2498 goto do_fstat;
2499 }
2500 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2501 tmpgv = (GV*)SvRV(sv);
2502 goto do_fstat;
2503 }
2d8e6c8d 2504 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2505 PL_statgv = Nullgv;
a0d0e21e 2506#ifdef HAS_LSTAT
533c011a
NIS
2507 PL_laststype = PL_op->op_type;
2508 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2509 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW
2510 else
2511#endif
2d8e6c8d 2512 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2513 if (PL_laststatval < 0) {
2d8e6c8d 2514 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2515 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW
2516 max = 0;
2517 }
2518 }
2519
54310121
PP
2520 gimme = GIMME_V;
2521 if (gimme != G_ARRAY) {
2522 if (gimme != G_VOID)
2523 XPUSHs(boolSV(max));
2524 RETURN;
a0d0e21e
LW
2525 }
2526 if (max) {
36477c24
PP
2527 EXTEND(SP, max);
2528 EXTEND_MORTAL(max);
1ff81528
PL
2529 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2530 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2531 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
2532 PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
887d2938
JH
2533#if Uid_t_size > IVSIZE
2534 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2535#else
1ff81528 2536 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
887d2938
JH
2537#endif
2538#if Gid_t_size > IVSIZE
2539 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2540#else
1ff81528 2541 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
887d2938 2542#endif
cbdc8872 2543#ifdef USE_STAT_RDEV
1ff81528 2544 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2545#else
79cb57f6 2546 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2547#endif
e0a10278 2548#if Off_t_size > IVSIZE
887d2938
JH
2549 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2550#else
1ff81528 2551 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
887d2938 2552#endif
cbdc8872 2553#ifdef BIG_TIME
172ae379
JH
2554 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2555 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2556 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2557#else
1ff81528
PL
2558 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2559 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2560 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2561#endif
a0d0e21e 2562#ifdef USE_STAT_BLOCKS
1ff81528
PL
2563 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
2564 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
a0d0e21e 2565#else
79cb57f6
GS
2566 PUSHs(sv_2mortal(newSVpvn("", 0)));
2567 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW
2568#endif
2569 }
2570 RETURN;
2571}
2572
2573PP(pp_ftrread)
2574{
5ff3f7a4 2575 I32 result;
4e35701f 2576 djSP;
5ff3f7a4 2577#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2578 STRLEN n_a;
5ff3f7a4 2579 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2580 result = access(TOPpx, R_OK);
5ff3f7a4
GS
2581 if (result == 0)
2582 RETPUSHYES;
2583 if (result < 0)
2584 RETPUSHUNDEF;
2585 RETPUSHNO;
22865c03
GS
2586 }
2587 else
cea2e8a9 2588 result = my_stat();
5ff3f7a4 2589#else
cea2e8a9 2590 result = my_stat();
5ff3f7a4 2591#endif
22865c03 2592 SPAGAIN;
a0d0e21e
LW
2593 if (result < 0)
2594 RETPUSHUNDEF;
3280af22 2595 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW
2596 RETPUSHYES;
2597 RETPUSHNO;
2598}
2599
2600PP(pp_ftrwrite)
2601{
5ff3f7a4 2602 I32 result;
4e35701f 2603 djSP;
5ff3f7a4 2604#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2605 STRLEN n_a;
5ff3f7a4 2606 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2607 result = access(TOPpx, W_OK);
5ff3f7a4
GS
2608 if (result == 0)
2609 RETPUSHYES;
2610 if (result < 0)
2611 RETPUSHUNDEF;
2612 RETPUSHNO;
22865c03
GS
2613 }
2614 else
cea2e8a9 2615 result = my_stat();
5ff3f7a4 2616#else
cea2e8a9 2617 result = my_stat();
5ff3f7a4 2618#endif
22865c03 2619 SPAGAIN;
a0d0e21e
LW
2620 if (result < 0)
2621 RETPUSHUNDEF;
3280af22 2622 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW
2623 RETPUSHYES;
2624 RETPUSHNO;
2625}
2626
2627PP(pp_ftrexec)
2628{
5ff3f7a4 2629 I32 result;
4e35701f 2630 djSP;
5ff3f7a4 2631#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2632 STRLEN n_a;
5ff3f7a4 2633 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2634 result = access(TOPpx, X_OK);
5ff3f7a4
GS
2635 if (result == 0)
2636 RETPUSHYES;
2637 if (result < 0)
2638 RETPUSHUNDEF;
2639 RETPUSHNO;
22865c03
GS
2640 }
2641 else
cea2e8a9 2642 result = my_stat();
5ff3f7a4 2643#else
cea2e8a9 2644 result = my_stat();
5ff3f7a4 2645#endif
22865c03 2646 SPAGAIN;
a0d0e21e
LW
2647 if (result < 0)
2648 RETPUSHUNDEF;
3280af22 2649 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW
2650 RETPUSHYES;
2651 RETPUSHNO;
2652}
2653
2654PP(pp_fteread)
2655{
5ff3f7a4 2656 I32 result;
4e35701f 2657 djSP;
5ff3f7a4 2658#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2659 STRLEN n_a;
5ff3f7a4 2660 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2661 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS
2662 if (result == 0)
2663 RETPUSHYES;
2664 if (result < 0)
2665 RETPUSHUNDEF;
2666 RETPUSHNO;
22865c03
GS
2667 }
2668 else
cea2e8a9 2669 result = my_stat();
5ff3f7a4 2670#else
cea2e8a9 2671 result = my_stat();
5ff3f7a4 2672#endif
22865c03 2673 SPAGAIN;
a0d0e21e
LW
2674 if (result < 0)
2675 RETPUSHUNDEF;
3280af22 2676 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW
2677 RETPUSHYES;
2678 RETPUSHNO;
2679}
2680
2681PP(pp_ftewrite)
2682{
5ff3f7a4 2683 I32 result;
4e35701f 2684 djSP;
5ff3f7a4 2685#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2686 STRLEN n_a;
5ff3f7a4 2687 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2688 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS
2689 if (result == 0)
2690 RETPUSHYES;
2691 if (result < 0)
2692 RETPUSHUNDEF;
2693 RETPUSHNO;
22865c03
GS
2694 }
2695 else
cea2e8a9 2696 result = my_stat();
5ff3f7a4 2697#else
cea2e8a9 2698 result = my_stat();
5ff3f7a4 2699#endif
22865c03 2700 SPAGAIN;
a0d0e21e
LW
2701 if (result < 0)
2702 RETPUSHUNDEF;
3280af22 2703 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW
2704 RETPUSHYES;
2705 RETPUSHNO;
2706}
2707
2708PP(pp_fteexec)
2709{
5ff3f7a4 2710 I32 result;
4e35701f 2711 djSP;
5ff3f7a4 2712#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2713 STRLEN n_a;
5ff3f7a4 2714 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2715 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS
2716 if (result == 0)
2717 RETPUSHYES;
2718 if (result < 0)
2719 RETPUSHUNDEF;
2720 RETPUSHNO;
22865c03
GS
2721 }
2722 else
cea2e8a9 2723 result = my_stat();
5ff3f7a4 2724#else
cea2e8a9 2725 result = my_stat();
5ff3f7a4 2726#endif
22865c03 2727 SPAGAIN;
a0d0e21e
LW
2728 if (result < 0)
2729 RETPUSHUNDEF;
3280af22 2730 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW
2731 RETPUSHYES;
2732 RETPUSHNO;
2733}
2734
2735PP(pp_ftis)
2736{
cea2e8a9 2737 I32 result = my_stat();
4e35701f 2738 djSP;
a0d0e21e
LW
2739 if (result < 0)
2740 RETPUSHUNDEF;
2741 RETPUSHYES;
2742}
2743
2744PP(pp_fteowned)
2745{
cea2e8a9 2746 return pp_ftrowned();
a0d0e21e
LW
2747}
2748
2749PP(pp_ftrowned)
2750{
cea2e8a9 2751 I32 result = my_stat();
4e35701f 2752 djSP;
a0d0e21e
LW
2753 if (result < 0)
2754 RETPUSHUNDEF;
887d2938
JH
2755 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2756 PL_euid : PL_uid) )
a0d0e21e
LW
2757 RETPUSHYES;
2758 RETPUSHNO;
2759}
2760
2761PP(pp_ftzero)
2762{
cea2e8a9 2763 I32 result = my_stat();
4e35701f 2764 djSP;
a0d0e21e
LW
2765 if (result < 0)
2766 RETPUSHUNDEF;
887d2938 2767 if (PL_statcache.st_size == 0)
a0d0e21e
LW
2768 RETPUSHYES;
2769 RETPUSHNO;
2770}
2771
2772PP(pp_ftsize)
2773{
cea2e8a9 2774 I32 result = my_stat();
4e35701f 2775 djSP; dTARGET;
a0d0e21e
LW
2776 if (result < 0)
2777 RETPUSHUNDEF;
e0a10278 2778#if Off_t_size > IVSIZE
887d2938
JH
2779 PUSHn(PL_statcache.st_size);
2780#else
3280af22 2781 PUSHi(PL_statcache.st_size);
887d2938 2782#endif
a0d0e21e
LW
2783 RETURN;
2784}
2785
2786PP(pp_ftmtime)
2787{
cea2e8a9 2788 I32 result = my_stat();
4e35701f 2789 djSP; dTARGET;
a0d0e21e
LW
2790 if (result < 0)
2791 RETPUSHUNDEF;
c6419e06 2792 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW
2793 RETURN;
2794}
2795
2796PP(pp_ftatime)
2797{
cea2e8a9 2798 I32 result = my_stat();
4e35701f 2799 djSP; dTARGET;
a0d0e21e
LW
2800 if (result < 0)
2801 RETPUSHUNDEF;
c6419e06 2802 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW
2803 RETURN;
2804}
2805
2806PP(pp_ftctime)
2807{
cea2e8a9 2808 I32 result = my_stat();
4e35701f 2809 djSP; dTARGET;
a0d0e21e
LW
2810 if (result < 0)
2811 RETPUSHUNDEF;
c6419e06 2812 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW
2813 RETURN;
2814}
2815
2816PP(pp_ftsock)
2817{
cea2e8a9 2818 I32 result = my_stat();
4e35701f 2819 djSP;
a0d0e21e
LW
2820 if (result < 0)
2821 RETPUSHUNDEF;
3280af22 2822 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW
2823 RETPUSHYES;
2824 RETPUSHNO;
2825}
2826
2827PP(pp_ftchr)
2828{
cea2e8a9 2829 I32 result = my_stat();
4e35701f 2830 djSP;
a0d0e21e
LW
2831 if (result < 0)
2832 RETPUSHUNDEF;
3280af22 2833 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW
2834 RETPUSHYES;
2835 RETPUSHNO;
2836}
2837
2838PP(pp_ftblk)
2839{
cea2e8a9 2840 I32 result = my_stat();
4e35701f 2841 djSP;
a0d0e21e
LW
2842 if (result < 0)
2843 RETPUSHUNDEF;
3280af22 2844 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW
2845 RETPUSHYES;
2846 RETPUSHNO;
2847}
2848
2849PP(pp_ftfile)
2850{
cea2e8a9 2851 I32 result = my_stat();
4e35701f 2852 djSP;
a0d0e21e
LW
2853 if (result < 0)
2854 RETPUSHUNDEF;
3280af22 2855 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW
2856 RETPUSHYES;
2857 RETPUSHNO;
2858}
2859
2860PP(pp_ftdir)
2861{
cea2e8a9 2862 I32 result = my_stat();
4e35701f 2863 djSP;
a0d0e21e
LW
2864 if (result < 0)
2865 RETPUSHUNDEF;
3280af22 2866 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW
2867 RETPUSHYES;
2868 RETPUSHNO;
2869}
2870
2871PP(pp_ftpipe)
2872{
cea2e8a9 2873 I32 result = my_stat();
4e35701f 2874 djSP;
a0d0e21e
LW
2875 if (result < 0)
2876 RETPUSHUNDEF;
3280af22 2877 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW
2878 RETPUSHYES;
2879 RETPUSHNO;
2880}
2881
2882PP(pp_ftlink)
2883{
cea2e8a9 2884 I32 result = my_lstat();
4e35701f 2885 djSP;
a0d0e21e
LW
2886 if (result < 0)
2887 RETPUSHUNDEF;
3280af22 2888 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW
2889 RETPUSHYES;
2890 RETPUSHNO;
2891}
2892
2893PP(pp_ftsuid)
2894{
4e35701f 2895 djSP;
a0d0e21e 2896#ifdef S_ISUID
cea2e8a9 2897 I32 result = my_stat();
a0d0e21e
LW
2898 SPAGAIN;
2899 if (result < 0)
2900 RETPUSHUNDEF;
3280af22 2901 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW
2902 RETPUSHYES;
2903#endif
2904 RETPUSHNO;
2905}
2906
2907PP(pp_ftsgid)
2908{
4e35701f 2909 djSP;
a0d0e21e 2910#ifdef S_ISGID
cea2e8a9 2911 I32 result = my_stat();
a0d0e21e
LW
2912 SPAGAIN;
2913 if (result < 0)
2914 RETPUSHUNDEF;
3280af22 2915 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW
2916 RETPUSHYES;
2917#endif
2918 RETPUSHNO;
2919}
2920
2921PP(pp_ftsvtx)
2922{
4e35701f 2923 djSP;
a0d0e21e 2924#ifdef S_ISVTX
cea2e8a9 2925 I32 result = my_stat();
a0d0e21e
LW
2926 SPAGAIN;
2927 if (result < 0)
2928 RETPUSHUNDEF;
3280af22 2929 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW
2930 RETPUSHYES;
2931#endif
2932 RETPUSHNO;
2933}
2934
2935PP(pp_fttty)
2936{
4e35701f 2937 djSP;
a0d0e21e
LW
2938 int fd;
2939 GV *gv;
fb73857a 2940 char *tmps = Nullch;
2d8e6c8d 2941 STRLEN n_a;
fb73857a 2942
533c011a 2943 if (PL_op->op_flags & OPf_REF)
638eceb6 2944 gv = cGVOP_gv;
fb73857a
PP
2945 else if (isGV(TOPs))
2946 gv = (GV*)POPs;
2947 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2948 gv = (GV*)SvRV(POPs);
a0d0e21e 2949 else
2d8e6c8d 2950 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2951
a0d0e21e 2952 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2953 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2954 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW
2955 fd = atoi(tmps);
2956 else
2957 RETPUSHUNDEF;
6ad3d225 2958 if (PerlLIO_isatty(fd))
a0d0e21e
LW
2959 RETPUSHYES;
2960 RETPUSHNO;
2961}
2962
16d20bd9
AD
2963#if defined(atarist) /* this will work with atariST. Configure will
2964 make guesses for other systems. */
2965# define FILE_base(f) ((f)->_base)
2966# define FILE_ptr(f) ((f)->_ptr)
2967# define FILE_cnt(f) ((f)->_cnt)
2968# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW
2969#endif
2970
2971PP(pp_fttext)
2972{
4e35701f 2973 djSP;
a0d0e21e
LW
2974 I32 i;
2975 I32 len;
2976 I32 odd = 0;
2977 STDCHAR tbuf[512];
2978 register STDCHAR *s;
2979 register IO *io;
5f05dabc
PP
2980 register SV *sv;
2981 GV *gv;
2d8e6c8d 2982 STRLEN n_a;
887d2938 2983 PerlIO *fp;
a0d0e21e 2984
533c011a 2985 if (PL_op->op_flags & OPf_REF)
638eceb6 2986 gv = cGVOP_gv;
5f05dabc
PP
2987 else if (isGV(TOPs))
2988 gv = (GV*)POPs;
2989 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2990 gv = (GV*)SvRV(POPs);
2991 else
2992 gv = Nullgv;
2993
2994 if (gv) {
a0d0e21e 2995 EXTEND(SP, 1);
3280af22
NIS
2996 if (gv == PL_defgv) {
2997 if (PL_statgv)
2998 io = GvIO(PL_statgv);
a0d0e21e 2999 else {
3280af22 3000 sv = PL_statname;
a0d0e21e
LW
3001 goto really_filename;
3002 }
3003 }
3004 else {
3280af22
NIS
3005 PL_statgv = gv;
3006 PL_laststatval = -1;
3007 sv_setpv(PL_statname, "");
3008 io = GvIO(PL_statgv);
a0d0e21e
LW
3009 }
3010 if (io && IoIFP(io)) {
5f05dabc 3011 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3012 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS
3013 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3014 if (PL_laststatval < 0)
5f05dabc 3015 RETPUSHUNDEF;
3280af22 3016 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3017 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3018 RETPUSHNO;
3019 else
3020 RETPUSHYES;
a20bf0c3 3021 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3022 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3023 if (i != EOF)
760ac839 3024 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3025 }
a20bf0c3 3026 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3027 RETPUSHYES;
a20bf0c3
JH
3028 len = PerlIO_get_bufsiz(IoIFP(io));
3029 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW
3030 /* sfio can have large buffers - limit to 512 */
3031 if (len > 512)
3032 len = 512;
a0d0e21e
LW
3033 }
3034 else {
7766f137 3035 if (ckWARN(WARN_UNOPENED)) {
638eceb6 3036 gv = cGVOP_gv;
cea2e8a9 3037 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
7766f137
GS
3038 GvENAME(gv));
3039 }
748a9306 3040 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
3041 RETPUSHUNDEF;
3042 }
3043 }
3044 else {
3045 sv = POPs;
5f05dabc 3046 really_filename:
3280af22
NIS
3047 PL_statgv = Nullgv;
3048 PL_laststatval = -1;
2d8e6c8d 3049 sv_setpv(PL_statname, SvPV(sv, n_a));
887d2938 3050 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3051 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3052 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW
3053 RETPUSHUNDEF;
3054 }
887d2938
JH
3055 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3056 if (PL_laststatval < 0) {
3057 (void)PerlIO_close(fp);
5f05dabc 3058 RETPUSHUNDEF;
887d2938
JH
3059 }
3060 do_binmode(fp, '<', TRUE);
3061 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3062 (void)PerlIO_close(fp);
a0d0e21e 3063 if (len <= 0) {
533c011a 3064 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3065 RETPUSHNO; /* special case NFS directories */
3066 RETPUSHYES; /* null file is anything */
3067 }
3068 s = tbuf;
3069 }
3070
3071 /* now scan s to look for textiness */
4633a7c4 3072 /* XXX ASCII dependent code */
a0d0e21e 3073
887d2938
JH
3074#if defined(DOSISH) || defined(USEMYBINMODE)
3075 /* ignore trailing ^Z on short files */
3076 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3077 --len;
3078#endif
3079
a0d0e21e
LW
3080 for (i = 0; i < len; i++, s++) {
3081 if (!*s) { /* null never allowed in text */
3082 odd += len;
3083 break;
3084 }
9d116dd7
JH
3085#ifdef EBCDIC
3086 else if (!(isPRINT(*s) || isSPACE(*s)))
3087 odd++;
3088#else
887d2938
JH
3089 else if (*s & 128) {
3090#ifdef USE_LOCALE
3091 if (!(PL_op->op_private & OPpLOCALE) || !isALPHA_LC(*s))
3092#endif
3093 odd++;
3094 }
a0d0e21e
LW
3095 else if (*s < 32 &&
3096 *s != '\n' && *s != '\r' && *s != '\b' &&
3097 *s != '\t' && *s != '\f' && *s != 27)
3098 odd++;
9d116dd7 3099#endif
a0d0e21e
LW
3100 }
3101
533c011a 3102 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW
3103 RETPUSHNO;
3104 else
3105 RETPUSHYES;
3106}
3107
3108PP(pp_ftbinary)
3109{
cea2e8a9 3110 return pp_fttext();
a0d0e21e
LW
3111}
3112
3113/* File calls. */
3114
3115PP(pp_chdir)
3116{
4e35701f 3117 djSP; dTARGET;
a0d0e21e
LW
3118 char *tmps;
3119 SV **svp;
2d8e6c8d 3120 STRLEN n_a;
a0d0e21e
LW
3121
3122 if (MAXARG < 1)
3123 tmps = Nullch;
3124 else
2d8e6c8d 3125 tmps = POPpx;
a0d0e21e 3126 if (!tmps || !*tmps) {
3280af22 3127 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3128 if (svp)
2d8e6c8d 3129 tmps = SvPV(*svp, n_a);
a0d0e21e
LW
3130 }
3131 if (!tmps || !*tmps) {
3280af22 3132 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3133 if (svp)
2d8e6c8d 3134 tmps = SvPV(*svp, n_a);
a0d0e21e 3135 }
491527d0
GS
3136#ifdef VMS
3137 if (!tmps || !*tmps) {
6b88bc9c 3138 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3139 if (svp)
2d8e6c8d 3140 tmps = SvPV(*svp, n_a);
491527d0
GS
3141 }
3142#endif
a0d0e21e 3143 TAINT_PROPER("chdir");
6ad3d225 3144 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW
3145#ifdef VMS
3146 /* Clear the DEFAULT element of ENV so we'll get the new value
3147 * in the future. */
6b88bc9c 3148 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3149#endif
a0d0e21e
LW
3150 RETURN;
3151}
3152
3153PP(pp_chown)
3154{
4e35701f 3155 djSP; dMARK; dTARGET;
a0d0e21e
LW
3156 I32 value;
3157#ifdef HAS_CHOWN
533c011a 3158 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3159 SP = MARK;
3160 PUSHi(value);
3161 RETURN;
3162#else
cea2e8a9 3163 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW
3164#endif
3165}
3166
3167PP(pp_chroot)
3168{
4e35701f 3169 djSP; dTARGET;
a0d0e21e
LW
3170 char *tmps;
3171#ifdef HAS_CHROOT
2d8e6c8d
GS
3172 STRLEN n_a;
3173 tmps = POPpx;
a0d0e21e
LW
3174 TAINT_PROPER("chroot");
3175 PUSHi( chroot(tmps) >= 0 );
3176 RETURN;
3177#else
cea2e8a9 3178 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW
3179#endif
3180}
3181
3182PP(pp_unlink)
3183{
4e35701f 3184 djSP; dMARK; dTARGET;
a0d0e21e 3185 I32 value;
533c011a 3186 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3187 SP = MARK;
3188 PUSHi(value);
3189 RETURN;
3190}
3191
3192PP(pp_chmod)
3193{
4e35701f 3194 djSP; dMARK; dTARGET;
a0d0e21e 3195 I32 value;
533c011a 3196 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3197 SP = MARK;
3198 PUSHi(value);
3199 RETURN;
3200}
3201
3202PP(pp_utime)
3203{
4e35701f 3204 djSP; dMARK; dTARGET;
a0d0e21e 3205 I32 value;
533c011a 3206 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3207 SP = MARK;
3208 PUSHi(value);
3209 RETURN;
3210}
3211
3212PP(pp_rename)
3213{
4e35701f 3214 djSP; dTARGET;
a0d0e21e 3215 int anum;
2d8e6c8d 3216 STRLEN n_a;
a0d0e21e 3217
2d8e6c8d
GS
3218 char *tmps2 = POPpx;
3219 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3220 TAINT_PROPER("rename");
3221#ifdef HAS_RENAME
baed7233 3222 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3223#else
6b88bc9c 3224 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
WK
3225 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3226 anum = 1;
3227 else {
3654eb6c 3228 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
WK
3229 (void)UNLINK(tmps2);
3230 if (!(anum = link(tmps, tmps2)))
3231 anum = UNLINK(tmps);
3232 }
a0d0e21e
LW
3233 }
3234#endif
3235 SETi( anum >= 0 );
3236 RETURN;
3237}
3238
3239PP(pp_link)
3240{
4e35701f 3241 djSP; dTARGET;
a0d0e21e 3242#ifdef HAS_LINK
2d8e6c8d
GS
3243 STRLEN n_a;
3244 char *tmps2 = POPpx;
3245 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3246 TAINT_PROPER("link");
6b980173 3247 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3248#else
cea2e8a9 3249 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW
3250#endif
3251 RETURN;
3252}
3253
3254PP(pp_symlink)
3255{
4e35701f 3256 djSP; dTARGET;
a0d0e21e 3257#ifdef HAS_SYMLINK
2d8e6c8d
GS
3258 STRLEN n_a;
3259 char *tmps2 = POPpx;
3260 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3261 TAINT_PROPER("symlink");
3262 SETi( symlink(tmps, tmps2) >= 0 );
3263 RETURN;
3264#else
cea2e8a9 3265 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW
3266#endif
3267}
3268
3269PP(pp_readlink)
3270{
4e35701f 3271 djSP; dTARGET;
a0d0e21e
LW
3272#ifdef HAS_SYMLINK
3273 char *tmps;
46fc3d4c 3274 char buf[MAXPATHLEN];
a0d0e21e 3275 int len;
2d8e6c8d 3276 STRLEN n_a;
46fc3d4c 3277
fb73857a
PP
3278#ifndef INCOMPLETE_TAINTS
3279 TAINT;
3280#endif
2d8e6c8d 3281 tmps = POPpx;
a0d0e21e
LW
3282 len = readlink(tmps, buf, sizeof buf);
3283 EXTEND(SP, 1);
3284 if (len < 0)
3285 RETPUSHUNDEF;
3286 PUSHp(buf, len);
3287 RETURN;
3288#else
3289 EXTEND(SP, 1);
3290 RETSETUNDEF; /* just pretend it's a normal file */
3291#endif
3292}
3293
3294#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3295STATIC int
cea2e8a9 3296S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3297{
1e422769
PP
3298 char *save_filename = filename;
3299 char *cmdline;
3300 char *s;
760ac839 3301 PerlIO *myfp;
1e422769 3302 int anum = 1;
a0d0e21e 3303
1e422769
PP
3304 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3305 strcpy(cmdline, cmd);
3306 strcat(cmdline, " ");
3307 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW
3308 *s++ = '\\';
3309 *s++ = *filename++;
3310 }
3311 strcpy(s, " 2>&1");
6ad3d225 3312 myfp = PerlProc_popen(cmdline, "r");
1e422769
PP
3313 Safefree(cmdline);
3314
a0d0e21e 3315 if (myfp) {
1e422769 3316 SV *tmpsv = sv_newmortal();
6b88bc9c 3317 /* Need to save/restore 'PL_rs' ?? */
760ac839 3318 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3319 (void)PerlProc_pclose(myfp);
a0d0e21e 3320 if (s != Nullch) {
1e422769
PP
3321 int e;
3322 for (e = 1;
a0d0e21e 3323#ifdef HAS_SYS_ERRLIST
1e422769
PP
3324 e <= sys_nerr
3325#endif
3326 ; e++)
3327 {
3328 /* you don't see this */
3329 char *errmsg =
3330#ifdef HAS_SYS_ERRLIST
3331 sys_errlist[e]
a0d0e21e 3332#else
1e422769 3333 strerror(e)
a0d0e21e 3334#endif
1e422769
PP
3335 ;
3336 if (!errmsg)
3337 break;
3338 if (instr(s, errmsg)) {
3339 SETERRNO(e,0);
3340 return 0;
3341 }
a0d0e21e 3342 }
748a9306 3343 SETERRNO(0,0);
a0d0e21e
LW
3344#ifndef EACCES
3345#define EACCES EPERM
3346#endif
1e422769 3347 if (instr(s, "cannot make"))
748a9306 3348 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3349 else if (instr(s, "existing file"))
748a9306 3350 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3351 else if (instr(s, "ile exists"))
748a9306 3352 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3353 else if (instr(s, "non-exist"))
748a9306 3354 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3355 else if (instr(s, "does not exist"))
748a9306 3356 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3357 else if (instr(s, "not empty"))
748a9306 3358 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3359 else if (instr(s, "cannot access"))
748a9306 3360 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3361 else
748a9306 3362 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW
3363 return 0;
3364 }
3365 else { /* some mkdirs return no failure indication */
6b88bc9c 3366 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3367 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW
3368 anum = !anum;
3369 if (anum)
748a9306 3370 SETERRNO(0,0);
a0d0e21e 3371 else
748a9306 3372 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW
3373 }
3374 return anum;
3375 }
3376 else
3377 return 0;
3378}
3379#endif
3380
3381PP(pp_mkdir)
3382{
4e35701f 3383 djSP; dTARGET;
5a211162 3384 int mode;
a0d0e21e
LW
3385#ifndef HAS_MKDIR
3386 int oldumask;
3387#endif
2d8e6c8d 3388 STRLEN n_a;
5a211162
GS
3389 char *tmps;
3390
3391 if (MAXARG > 1)
3392 mode = POPi;
3393 else
3394 mode = 0777;
3395
3396 tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3397
3398 TAINT_PROPER("mkdir");
3399#ifdef HAS_MKDIR
6ad3d225 3400 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW
3401#else
3402 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS
3403 oldumask = PerlLIO_umask(0);
3404 PerlLIO_umask(oldumask);
3405 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW
3406#endif
3407 RETURN;
3408}
3409
3410PP(pp_rmdir)
3411{
4e35701f 3412 djSP; dTARGET;
a0d0e21e 3413 char *tmps;
2d8e6c8d 3414 STRLEN n_a;
a0d0e21e 3415
2d8e6c8d 3416 tmps = POPpx;
a0d0e21e
LW
3417 TAINT_PROPER("rmdir");
3418#ifdef HAS_RMDIR
6ad3d225 3419 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW
3420#else
3421 XPUSHi( dooneliner("rmdir", tmps) );
3422#endif
3423 RETURN;
3424}
3425
3426/* Directory calls. */
3427
3428PP(pp_open_dir)
3429{
4e35701f 3430 djSP;
a0d0e21e 3431#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS
3432 STRLEN n_a;
3433 char *dirname = POPpx;
a0d0e21e
LW
3434 GV *gv = (GV*)POPs;
3435 register IO *io = GvIOn(gv);
3436
3437 if (!io)
3438 goto nope;
3439
3440 if (IoDIRP(io))
6ad3d225
GS
3441 PerlDir_close(IoDIRP(io));
3442 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW
3443 goto nope;
3444
3445 RETPUSHYES;
3446nope:
3447 if (!errno)
748a9306 3448 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW
3449 RETPUSHUNDEF;
3450#else
cea2e8a9 3451 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW
3452#endif
3453}
3454
3455PP(pp_readdir)
3456{
4e35701f 3457 djSP;
a0d0e21e
LW
3458#if defined(Direntry_t) && defined(HAS_READDIR)
3459#ifndef I_DIRENT
20ce7b12 3460 Direntry_t *readdir (DIR *);
a0d0e21e
LW
3461#endif
3462 register Direntry_t *dp;
3463 GV *gv = (GV*)POPs;
3464 register IO *io = GvIOn(gv);
fb73857a 3465 SV *sv;
a0d0e21e
LW
3466
3467 if (!io || !IoDIRP(io))
3468 goto nope;
3469
3470 if (GIMME == G_ARRAY) {
3471 /*SUPPRESS 560*/
6ad3d225 3472 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3473#ifdef DIRNAMLEN
79cb57f6 3474 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3475#else
fb73857a
PP
3476 sv = newSVpv(dp->d_name, 0);
3477#endif
3478#ifndef INCOMPLETE_TAINTS
3479 SvTAINTED_on(sv);
a0d0e21e 3480#endif
fb73857a 3481 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
3482 }
3483 }
3484 else {
6ad3d225 3485 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW
3486 goto nope;
3487#ifdef DIRNAMLEN
79cb57f6 3488 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3489#else
fb73857a 3490 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3491#endif
fb73857a
PP
3492#ifndef INCOMPLETE_TAINTS
3493 SvTAINTED_on(sv);
3494#endif
3495 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
3496 }
3497 RETURN;
3498
3499nope:
3500 if (!errno)
748a9306 3501 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3502 if (GIMME == G_ARRAY)
3503 RETURN;
3504 else
3505 RETPUSHUNDEF;
3506#else
cea2e8a9 3507 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW
3508#endif
3509}
3510
3511PP(pp_telldir)
3512{
4e35701f 3513 djSP; dTARGET;
a0d0e21e 3514#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH
3515 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3516 /* XXX netbsd still seemed to.
3517 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3518 --JHI 1999-Feb-02 */
3519# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3520 long telldir (DIR *);
dfe9444c 3521# endif
a0d0e21e
LW
3522 GV *gv = (GV*)POPs;
3523 register IO *io = GvIOn(gv);
3524
3525 if (!io || !IoDIRP(io))
3526 goto nope;
3527
6ad3d225 3528 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW
3529 RETURN;
3530nope:
3531 if (!errno)
748a9306 3532 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3533 RETPUSHUNDEF;
3534#else
cea2e8a9 3535 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW
3536#endif
3537}
3538
3539PP(pp_seekdir)
3540{
4e35701f 3541 djSP;
a0d0e21e
LW
3542#if defined(HAS_SEEKDIR) || defined(seekdir)
3543 long along = POPl;
3544 GV *gv = (GV*)POPs;
3545 register IO *io = GvIOn(gv);
3546
3547 if (!io || !IoDIRP(io))
3548 goto nope;
3549
6ad3d225 3550 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW
3551
3552 RETPUSHYES;
3553nope:
3554 if (!errno)
748a9306 3555 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3556 RETPUSHUNDEF;
3557#else
cea2e8a9 3558 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW
3559#endif
3560}
3561
3562PP(pp_rewinddir)
3563{
4e35701f 3564 djSP;
a0d0e21e
LW
3565#if defined(HAS_REWINDDIR) || defined(rewinddir)
3566 GV *gv = (GV*)POPs;
3567 register IO *io = GvIOn(gv);
3568
3569 if (!io || !IoDIRP(io))
3570 goto nope;
3571
6ad3d225 3572 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW
3573 RETPUSHYES;
3574nope:
3575 if (!errno)
748a9306 3576 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3577 RETPUSHUNDEF;
3578#else
cea2e8a9 3579 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW
3580#endif
3581}
3582
3583PP(pp_closedir)
3584{
4e35701f 3585 djS