This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Free tied hash iterator state immediately at the `untie` call
[perl5.git] / pp_sys.c
1 /*    pp_sys.c
2  *
3  *    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4  *    2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * But only a short way ahead its floor and the walls on either side were
13  * cloven by a great fissure, out of which the red glare came, now leaping
14  * up, now dying down into darkness; and all the while far below there was
15  * a rumour and a trouble as of great engines throbbing and labouring.
16  *
17  *     [p.945 of _The Lord of the Rings_, VI/iii: "Mount Doom"]
18  */
19
20 /* This file contains system pp ("push/pop") functions that
21  * execute the opcodes that make up a perl program. A typical pp function
22  * expects to find its arguments on the stack, and usually pushes its
23  * results onto the stack, hence the 'pp' terminology. Each OP structure
24  * contains a pointer to the relevant pp_foo() function.
25  *
26  * By 'system', we mean ops which interact with the OS, such as pp_open().
27  */
28
29 #include "EXTERN.h"
30 #define PERL_IN_PP_SYS_C
31 #include "perl.h"
32 #include "time64.h"
33
34 #ifdef I_SHADOW
35 /* Shadow password support for solaris - pdo@cs.umd.edu
36  * Not just Solaris: at least HP-UX, IRIX, Linux.
37  * The API is from SysV.
38  *
39  * There are at least two more shadow interfaces,
40  * see the comments in pp_gpwent().
41  *
42  * --jhi */
43 #   ifdef __hpux__
44 /* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
45  * and another MAXINT from "perl.h" <- <sys/param.h>. */
46 #       undef MAXINT
47 #   endif
48 #   include <shadow.h>
49 #endif
50
51 #ifdef I_SYS_RESOURCE
52 # include <sys/resource.h>
53 #endif
54
55 #ifdef NETWARE
56 NETDB_DEFINE_CONTEXT
57 #endif
58
59 #ifdef HAS_SELECT
60 # ifdef I_SYS_SELECT
61 #  include <sys/select.h>
62 # endif
63 #endif
64
65 /* XXX Configure test needed.
66    h_errno might not be a simple 'int', especially for multi-threaded
67    applications, see "extern int errno in perl.h".  Creating such
68    a test requires taking into account the differences between
69    compiling multithreaded and singlethreaded ($ccflags et al).
70    HOST_NOT_FOUND is typically defined in <netdb.h>.
71 */
72 #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
73 extern int h_errno;
74 #endif
75
76 #ifdef HAS_PASSWD
77 # ifdef I_PWD
78 #  include <pwd.h>
79 # elif !defined(VMS)
80     struct passwd *getpwnam (char *);
81     struct passwd *getpwuid (Uid_t);
82 # endif
83 # ifdef HAS_GETPWENT
84 #  ifndef getpwent
85   struct passwd *getpwent (void);
86 #  elif defined (VMS) && defined (my_getpwent)
87   struct passwd *Perl_my_getpwent (pTHX);
88 #  endif
89 # endif
90 #endif
91
92 #ifdef HAS_GROUP
93 # ifdef I_GRP
94 #  include <grp.h>
95 # else
96     struct group *getgrnam (char *);
97     struct group *getgrgid (Gid_t);
98 # endif
99 # ifdef HAS_GETGRENT
100 #  ifndef getgrent
101     struct group *getgrent (void);
102 #  endif
103 # endif
104 #endif
105
106 #ifdef I_UTIME
107 #  if defined(_MSC_VER) || defined(__MINGW32__)
108 #    include <sys/utime.h>
109 #  else
110 #    include <utime.h>
111 #  endif
112 #endif
113
114 #ifdef HAS_CHSIZE
115 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
116 #   undef my_chsize
117 # endif
118 # define my_chsize PerlLIO_chsize
119 #elif defined(HAS_TRUNCATE)
120 # define my_chsize PerlLIO_chsize
121 #else
122 I32 my_chsize(int fd, Off_t length);
123 #endif
124
125 #ifdef HAS_FLOCK
126 #  define FLOCK flock
127 #else /* no flock() */
128
129    /* fcntl.h might not have been included, even if it exists, because
130       the current Configure only sets I_FCNTL if it's needed to pick up
131       the *_OK constants.  Make sure it has been included before testing
132       the fcntl() locking constants. */
133 #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
134 #    include <fcntl.h>
135 #  endif
136
137 #  if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
138 #    define FLOCK fcntl_emulate_flock
139 #    define FCNTL_EMULATE_FLOCK
140 #  elif defined(HAS_LOCKF)
141 #    define FLOCK lockf_emulate_flock
142 #    define LOCKF_EMULATE_FLOCK
143 #  endif
144
145 #  ifdef FLOCK
146      static int FLOCK (int, int);
147
148     /*
149      * These are the flock() constants.  Since this sytems doesn't have
150      * flock(), the values of the constants are probably not available.
151      */
152 #    ifndef LOCK_SH
153 #      define LOCK_SH 1
154 #    endif
155 #    ifndef LOCK_EX
156 #      define LOCK_EX 2
157 #    endif
158 #    ifndef LOCK_NB
159 #      define LOCK_NB 4
160 #    endif
161 #    ifndef LOCK_UN
162 #      define LOCK_UN 8
163 #    endif
164 #  endif /* emulating flock() */
165
166 #endif /* no flock() */
167
168 #define ZBTLEN 10
169 static const char zero_but_true[ZBTLEN + 1] = "0 but true";
170
171 #if defined(I_SYS_ACCESS) && !defined(R_OK)
172 #  include <sys/access.h>
173 #endif
174
175 #include "reentr.h"
176
177 #ifdef __Lynx__
178 /* Missing protos on LynxOS */
179 void sethostent(int);
180 void endhostent(void);
181 void setnetent(int);
182 void endnetent(void);
183 void setprotoent(int);
184 void endprotoent(void);
185 void setservent(int);
186 void endservent(void);
187 #endif
188
189 #ifdef __amigaos4__
190 #  include "amigaos4/amigaio.h"
191 #endif
192
193 #undef PERL_EFF_ACCESS  /* EFFective uid/gid ACCESS */
194
195 /* F_OK unused: if stat() cannot find it... */
196
197 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
198     /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
199 #   define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
200 #endif
201
202 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
203 #   ifdef I_SYS_SECURITY
204 #       include <sys/security.h>
205 #   endif
206 #   ifdef ACC_SELF
207         /* HP SecureWare */
208 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
209 #   else
210         /* SCO */
211 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
212 #   endif
213 #endif
214
215 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
216     /* AIX's accessx() doesn't declare its argument const, unlike every other platform */
217 #   define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF))
218 #endif
219
220
221 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS)    \
222     && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)         \
223         || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
224 /* The Hard Way. */
225 STATIC int
226 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
227 {
228     const Uid_t ruid = getuid();
229     const Uid_t euid = geteuid();
230     const Gid_t rgid = getgid();
231     const Gid_t egid = getegid();
232     int res;
233
234 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
235     Perl_croak(aTHX_ "switching effective uid is not implemented");
236 #else
237 #  ifdef HAS_SETREUID
238     if (setreuid(euid, ruid))
239 #  elif defined(HAS_SETRESUID)
240     if (setresuid(euid, ruid, (Uid_t)-1))
241 #  endif
242         /* diag_listed_as: entering effective %s failed */
243         Perl_croak(aTHX_ "entering effective uid failed");
244 #endif
245
246 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
247     Perl_croak(aTHX_ "switching effective gid is not implemented");
248 #else
249 #  ifdef HAS_SETREGID
250     if (setregid(egid, rgid))
251 #  elif defined(HAS_SETRESGID)
252     if (setresgid(egid, rgid, (Gid_t)-1))
253 #  endif
254         /* diag_listed_as: entering effective %s failed */
255         Perl_croak(aTHX_ "entering effective gid failed");
256 #endif
257
258     res = access(path, mode);
259
260 #ifdef HAS_SETREUID
261     if (setreuid(ruid, euid))
262 #elif defined(HAS_SETRESUID)
263     if (setresuid(ruid, euid, (Uid_t)-1))
264 #endif
265         /* diag_listed_as: leaving effective %s failed */
266         Perl_croak(aTHX_ "leaving effective uid failed");
267
268 #ifdef HAS_SETREGID
269     if (setregid(rgid, egid))
270 #elif defined(HAS_SETRESGID)
271     if (setresgid(rgid, egid, (Gid_t)-1))
272 #endif
273         /* diag_listed_as: leaving effective %s failed */
274         Perl_croak(aTHX_ "leaving effective gid failed");
275
276     return res;
277 }
278 #   define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
279 #endif
280
281 PP(pp_backtick)
282 {
283     dSP; dTARGET;
284     PerlIO *fp;
285     const char * const tmps = POPpconstx;
286     const U8 gimme = GIMME_V;
287     const char *mode = "r";
288
289     TAINT_PROPER("``");
290     if (PL_op->op_private & OPpOPEN_IN_RAW)
291         mode = "rb";
292     else if (PL_op->op_private & OPpOPEN_IN_CRLF)
293         mode = "rt";
294     fp = PerlProc_popen(tmps, mode);
295     if (fp) {
296         const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
297         if (type && *type)
298             PerlIO_apply_layers(aTHX_ fp,mode,type);
299
300         if (gimme == G_VOID) {
301             char tmpbuf[256];
302             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
303                 NOOP;
304         }
305         else if (gimme == G_SCALAR) {
306             ENTER_with_name("backtick");
307             SAVESPTR(PL_rs);
308             PL_rs = &PL_sv_undef;
309             SvPVCLEAR(TARG);        /* note that this preserves previous buffer */
310             while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
311                 NOOP;
312             LEAVE_with_name("backtick");
313             XPUSHs(TARG);
314             SvTAINTED_on(TARG);
315         }
316         else {
317             for (;;) {
318                 SV * const sv = newSV(79);
319                 if (sv_gets(sv, fp, 0) == NULL) {
320                     SvREFCNT_dec(sv);
321                     break;
322                 }
323                 mXPUSHs(sv);
324                 if (SvLEN(sv) - SvCUR(sv) > 20) {
325                     SvPV_shrink_to_cur(sv);
326                 }
327                 SvTAINTED_on(sv);
328             }
329         }
330         STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
331         TAINT;          /* "I believe that this is not gratuitous!" */
332     }
333     else {
334         STATUS_NATIVE_CHILD_SET(-1);
335         if (gimme == G_SCALAR)
336             RETPUSHUNDEF;
337     }
338
339     RETURN;
340 }
341
342 PP(pp_glob)
343 {
344     OP *result;
345     dSP;
346     GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
347
348     PUTBACK;
349
350     /* make a copy of the pattern if it is gmagical, to ensure that magic
351      * is called once and only once */
352     if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
353
354     tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
355
356     if (PL_op->op_flags & OPf_SPECIAL) {
357         /* call Perl-level glob function instead. Stack args are:
358          * MARK, wildcard
359          * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
360          * */
361         return NORMAL;
362     }
363     if (PL_globhook) {
364         PL_globhook(aTHX);
365         return NORMAL;
366     }
367
368     /* Note that we only ever get here if File::Glob fails to load
369      * without at the same time croaking, for some reason, or if
370      * perl was built with PERL_EXTERNAL_GLOB */
371
372     ENTER_with_name("glob");
373
374 #ifndef VMS
375     if (TAINTING_get) {
376         /*
377          * The external globbing program may use things we can't control,
378          * so for security reasons we must assume the worst.
379          */
380         TAINT;
381         taint_proper(PL_no_security, "glob");
382     }
383 #endif /* !VMS */
384
385     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
386     PL_last_in_gv = gv;
387
388     SAVESPTR(PL_rs);            /* This is not permanent, either. */
389     PL_rs = newSVpvs_flags("\000", SVs_TEMP);
390 #ifndef DOSISH
391 #ifndef CSH
392     *SvPVX(PL_rs) = '\n';
393 #endif  /* !CSH */
394 #endif  /* !DOSISH */
395
396     result = do_readline();
397     LEAVE_with_name("glob");
398     return result;
399 }
400
401 PP(pp_rcatline)
402 {
403     PL_last_in_gv = cGVOP_gv;
404     return do_readline();
405 }
406
407 PP(pp_warn)
408 {
409     dSP; dMARK;
410     SV *exsv;
411     STRLEN len;
412     if (SP - MARK > 1) {
413         dTARGET;
414         do_join(TARG, &PL_sv_no, MARK, SP);
415         exsv = TARG;
416         SP = MARK + 1;
417     }
418     else if (SP == MARK) {
419         exsv = &PL_sv_no;
420         MEXTEND(SP, 1);
421         SP = MARK + 1;
422     }
423     else {
424         exsv = TOPs;
425         if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
426     }
427
428     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
429         /* well-formed exception supplied */
430     }
431     else {
432       SV * const errsv = ERRSV;
433       SvGETMAGIC(errsv);
434       if (SvROK(errsv)) {
435         if (SvGMAGICAL(errsv)) {
436             exsv = sv_newmortal();
437             sv_setsv_nomg(exsv, errsv);
438         }
439         else exsv = errsv;
440       }
441       else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
442         exsv = sv_newmortal();
443         sv_setsv_nomg(exsv, errsv);
444         sv_catpvs(exsv, "\t...caught");
445       }
446       else {
447         exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
448       }
449     }
450     if (SvROK(exsv) && !PL_warnhook)
451          Perl_warn(aTHX_ "%" SVf, SVfARG(exsv));
452     else warn_sv(exsv);
453     RETSETYES;
454 }
455
456 PP(pp_die)
457 {
458     dSP; dMARK;
459     SV *exsv;
460     STRLEN len;
461 #ifdef VMS
462     VMSISH_HUSHED  =
463         VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
464 #endif
465     if (SP - MARK != 1) {
466         dTARGET;
467         do_join(TARG, &PL_sv_no, MARK, SP);
468         exsv = TARG;
469         SP = MARK + 1;
470     }
471     else {
472         exsv = TOPs;
473     }
474
475     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
476         /* well-formed exception supplied */
477     }
478     else {
479         SV * const errsv = ERRSV;
480         SvGETMAGIC(errsv);
481         if (SvROK(errsv)) {
482             exsv = errsv;
483             if (sv_isobject(exsv)) {
484                 HV * const stash = SvSTASH(SvRV(exsv));
485                 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
486                 if (gv) {
487                     SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
488                     SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
489                     EXTEND(SP, 3);
490                     PUSHMARK(SP);
491                     PUSHs(exsv);
492                     PUSHs(file);
493                     PUSHs(line);
494                     PUTBACK;
495                     call_sv(MUTABLE_SV(GvCV(gv)),
496                             G_SCALAR|G_EVAL|G_KEEPERR);
497                     exsv = sv_mortalcopy(*PL_stack_sp--);
498                 }
499             }
500         }
501         else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) {
502             exsv = sv_mortalcopy(errsv);
503             sv_catpvs(exsv, "\t...propagated");
504         }
505         else {
506             exsv = newSVpvs_flags("Died", SVs_TEMP);
507         }
508     }
509     die_sv(exsv);
510     NOT_REACHED; /* NOTREACHED */
511     return NULL; /* avoid missing return from non-void function warning */
512 }
513
514 /* I/O. */
515
516 OP *
517 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
518                  const MAGIC *const mg, const U32 flags, U32 argc, ...)
519 {
520     SV **orig_sp = sp;
521     I32 ret_args;
522     SSize_t extend_size;
523
524     PERL_ARGS_ASSERT_TIED_METHOD;
525
526     /* Ensure that our flag bits do not overlap.  */
527     STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
528     STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
529     STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
530
531     PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
532     PUSHSTACKi(PERLSI_MAGIC);
533     /* extend for object + args. If argc might wrap/truncate when cast
534      * to SSize_t and incremented, set to -1, which will trigger a panic in
535      * EXTEND().
536      * The weird way this is written is because g++ is dumb enough to
537      * warn "comparison is always false" on something like:
538      *
539      * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1
540      *
541      * (where the LH condition is false)
542      */
543     extend_size =
544         (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc))
545             ? -1 : (SSize_t)argc + 1;
546     EXTEND(SP, extend_size);
547     PUSHMARK(sp);
548     PUSHs(SvTIED_obj(sv, mg));
549     if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
550         Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
551         sp += argc;
552     }
553     else if (argc) {
554         const U32 mortalize_not_needed
555             = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
556         va_list args;
557         va_start(args, argc);
558         do {
559             SV *const arg = va_arg(args, SV *);
560             if(mortalize_not_needed)
561                 PUSHs(arg);
562             else
563                 mPUSHs(arg);
564         } while (--argc);
565         va_end(args);
566     }
567
568     PUTBACK;
569     ENTER_with_name("call_tied_method");
570     if (flags & TIED_METHOD_SAY) {
571         /* local $\ = "\n" */
572         SAVEGENERICSV(PL_ors_sv);
573         PL_ors_sv = newSVpvs("\n");
574     }
575     ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
576     SPAGAIN;
577     orig_sp = sp;
578     POPSTACK;
579     SPAGAIN;
580     if (ret_args) { /* copy results back to original stack */
581         EXTEND(sp, ret_args);
582         Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
583         sp += ret_args;
584         PUTBACK;
585     }
586     LEAVE_with_name("call_tied_method");
587     return NORMAL;
588 }
589
590 #define tied_method0(a,b,c,d)           \
591     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
592 #define tied_method1(a,b,c,d,e)         \
593     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
594 #define tied_method2(a,b,c,d,e,f)       \
595     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
596
597 PP(pp_open)
598 {
599     dSP;
600     dMARK; dORIGMARK;
601     dTARGET;
602     SV *sv;
603     IO *io;
604     const char *tmps;
605     STRLEN len;
606     bool  ok;
607
608     GV * const gv = MUTABLE_GV(*++MARK);
609
610     if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
611         DIE(aTHX_ PL_no_usym, "filehandle");
612
613     if ((io = GvIOp(gv))) {
614         const MAGIC *mg;
615         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
616
617         if (IoDIRP(io))
618             Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle",
619                              HEKfARG(GvENAME_HEK(gv)));
620
621         mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
622         if (mg) {
623             /* Method's args are same as ours ... */
624             /* ... except handle is replaced by the object */
625             return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
626                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
627                                     sp - mark);
628         }
629     }
630
631     if (MARK < SP) {
632         sv = *++MARK;
633     }
634     else {
635         sv = GvSVn(gv);
636     }
637
638     tmps = SvPV_const(sv, len);
639     ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
640     SP = ORIGMARK;
641     if (ok)
642         PUSHi( (I32)PL_forkprocess );
643     else if (PL_forkprocess == 0)               /* we are a new child */
644         PUSHs(&PL_sv_zero);
645     else
646         RETPUSHUNDEF;
647     RETURN;
648 }
649
650 PP(pp_close)
651 {
652     dSP;
653     /* pp_coreargs pushes a NULL to indicate no args passed to
654      * CORE::close() */
655     GV * const gv =
656         MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
657
658     if (MAXARG == 0)
659         EXTEND(SP, 1);
660
661     if (gv) {
662         IO * const io = GvIO(gv);
663         if (io) {
664             const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
665             if (mg) {
666                 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
667             }
668         }
669     }
670     PUSHs(boolSV(do_close(gv, TRUE)));
671     RETURN;
672 }
673
674 PP(pp_pipe_op)
675 {
676 #ifdef HAS_PIPE
677     dSP;
678     IO *rstio;
679     IO *wstio;
680     int fd[2];
681
682     GV * const wgv = MUTABLE_GV(POPs);
683     GV * const rgv = MUTABLE_GV(POPs);
684
685     rstio = GvIOn(rgv);
686     if (IoIFP(rstio))
687         do_close(rgv, FALSE);
688
689     wstio = GvIOn(wgv);
690     if (IoIFP(wstio))
691         do_close(wgv, FALSE);
692
693     if (PerlProc_pipe_cloexec(fd) < 0)
694         goto badexit;
695
696     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE);
697     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE);
698     IoOFP(rstio) = IoIFP(rstio);
699     IoIFP(wstio) = IoOFP(wstio);
700     IoTYPE(rstio) = IoTYPE_RDONLY;
701     IoTYPE(wstio) = IoTYPE_WRONLY;
702
703     if (!IoIFP(rstio) || !IoOFP(wstio)) {
704         if (IoIFP(rstio))
705             PerlIO_close(IoIFP(rstio));
706         else
707             PerlLIO_close(fd[0]);
708         if (IoOFP(wstio))
709             PerlIO_close(IoOFP(wstio));
710         else
711             PerlLIO_close(fd[1]);
712         goto badexit;
713     }
714     RETPUSHYES;
715
716   badexit:
717     RETPUSHUNDEF;
718 #else
719     DIE(aTHX_ PL_no_func, "pipe");
720 #endif
721 }
722
723 PP(pp_fileno)
724 {
725     dSP; dTARGET;
726     GV *gv;
727     IO *io;
728     PerlIO *fp;
729     const MAGIC *mg;
730
731     if (MAXARG < 1)
732         RETPUSHUNDEF;
733     gv = MUTABLE_GV(POPs);
734     io = GvIO(gv);
735
736     if (io
737         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
738     {
739         return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
740     }
741
742     if (io && IoDIRP(io)) {
743 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
744         PUSHi(my_dirfd(IoDIRP(io)));
745         RETURN;
746 #elif defined(ENOTSUP)
747         errno = ENOTSUP;        /* Operation not supported */
748         RETPUSHUNDEF;
749 #elif defined(EOPNOTSUPP)
750         errno = EOPNOTSUPP;     /* Operation not supported on socket */
751         RETPUSHUNDEF;
752 #else
753         errno = EINVAL;         /* Invalid argument */
754         RETPUSHUNDEF;
755 #endif
756     }
757
758     if (!io || !(fp = IoIFP(io))) {
759         /* Can't do this because people seem to do things like
760            defined(fileno($foo)) to check whether $foo is a valid fh.
761
762            report_evil_fh(gv);
763             */
764         RETPUSHUNDEF;
765     }
766
767     PUSHi(PerlIO_fileno(fp));
768     RETURN;
769 }
770
771 PP(pp_umask)
772 {
773     dSP;
774 #ifdef HAS_UMASK
775     dTARGET;
776     Mode_t anum;
777
778     if (MAXARG < 1 || (!TOPs && !POPs)) {
779         anum = PerlLIO_umask(022);
780         /* setting it to 022 between the two calls to umask avoids
781          * to have a window where the umask is set to 0 -- meaning
782          * that another thread could create world-writeable files. */
783         if (anum != 022)
784             (void)PerlLIO_umask(anum);
785     }
786     else
787         anum = PerlLIO_umask(POPi);
788     TAINT_PROPER("umask");
789     XPUSHi(anum);
790 #else
791     /* Only DIE if trying to restrict permissions on "user" (self).
792      * Otherwise it's harmless and more useful to just return undef
793      * since 'group' and 'other' concepts probably don't exist here. */
794     if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
795         DIE(aTHX_ "umask not implemented");
796     XPUSHs(&PL_sv_undef);
797 #endif
798     RETURN;
799 }
800
801 PP(pp_binmode)
802 {
803     dSP;
804     GV *gv;
805     IO *io;
806     PerlIO *fp;
807     SV *discp = NULL;
808
809     if (MAXARG < 1)
810         RETPUSHUNDEF;
811     if (MAXARG > 1) {
812         discp = POPs;
813     }
814
815     gv = MUTABLE_GV(POPs);
816     io = GvIO(gv);
817
818     if (io) {
819         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
820         if (mg) {
821             /* This takes advantage of the implementation of the varargs
822                function, which I don't think that the optimiser will be able to
823                figure out. Although, as it's a static function, in theory it
824                could.  */
825             return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
826                                     G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
827                                     discp ? 1 : 0, discp);
828         }
829     }
830
831     if (!io || !(fp = IoIFP(io))) {
832         report_evil_fh(gv);
833         SETERRNO(EBADF,RMS_IFI);
834         RETPUSHUNDEF;
835     }
836
837     PUTBACK;
838     {
839         STRLEN len = 0;
840         const char *d = NULL;
841         int mode;
842         if (discp)
843             d = SvPV_const(discp, len);
844         mode = mode_from_discipline(d, len);
845         if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
846             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
847                 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
848                     SPAGAIN;
849                     RETPUSHUNDEF;
850                 }
851             }
852             SPAGAIN;
853             RETPUSHYES;
854         }
855         else {
856             SPAGAIN;
857             RETPUSHUNDEF;
858         }
859     }
860 }
861
862 PP(pp_tie)
863 {
864     dSP; dMARK;
865     HV* stash;
866     GV *gv = NULL;
867     SV *sv;
868     const I32 markoff = MARK - PL_stack_base;
869     const char *methname;
870     int how = PERL_MAGIC_tied;
871     U32 items;
872     SV *varsv = *++MARK;
873
874     switch(SvTYPE(varsv)) {
875         case SVt_PVHV:
876         {
877             HE *entry;
878             methname = "TIEHASH";
879             if (HvLAZYDEL(varsv) && (entry = HvEITER_get((HV *)varsv))) {
880                 HvLAZYDEL_off(varsv);
881                 hv_free_ent((HV *)varsv, entry);
882             }
883             HvEITER_set(MUTABLE_HV(varsv), 0);
884             HvRITER_set(MUTABLE_HV(varsv), -1);
885             break;
886         }
887         case SVt_PVAV:
888             methname = "TIEARRAY";
889             if (!AvREAL(varsv)) {
890                 if (!AvREIFY(varsv))
891                     Perl_croak(aTHX_ "Cannot tie unreifiable array");
892                 av_clear((AV *)varsv);
893                 AvREIFY_off(varsv);
894                 AvREAL_on(varsv);
895             }
896             break;
897         case SVt_PVGV:
898         case SVt_PVLV:
899             if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
900                 methname = "TIEHANDLE";
901                 how = PERL_MAGIC_tiedscalar;
902                 /* For tied filehandles, we apply tiedscalar magic to the IO
903                    slot of the GP rather than the GV itself. AMS 20010812 */
904                 if (!GvIOp(varsv))
905                     GvIOp(varsv) = newIO();
906                 varsv = MUTABLE_SV(GvIOp(varsv));
907                 break;
908             }
909             if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
910                 vivify_defelem(varsv);
911                 varsv = LvTARG(varsv);
912             }
913             /* FALLTHROUGH */
914         default:
915             methname = "TIESCALAR";
916             how = PERL_MAGIC_tiedscalar;
917             break;
918     }
919     items = SP - MARK++;
920     if (sv_isobject(*MARK)) { /* Calls GET magic. */
921         ENTER_with_name("call_TIE");
922         PUSHSTACKi(PERLSI_MAGIC);
923         PUSHMARK(SP);
924         EXTEND(SP,(I32)items);
925         while (items--)
926             PUSHs(*MARK++);
927         PUTBACK;
928         call_method(methname, G_SCALAR);
929     }
930     else {
931         /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
932          * will attempt to invoke IO::File::TIEARRAY, with (best case) the
933          * wrong error message, and worse case, supreme action at a distance.
934          * (Sorry obfuscation writers. You're not going to be given this one.)
935          */
936        stash = gv_stashsv(*MARK, 0);
937        if (!stash) {
938            if (SvROK(*MARK))
939                DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
940                    methname, SVfARG(*MARK));
941            else if (isGV(*MARK)) {
942                /* If the glob doesn't name an existing package, using
943                 * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So
944                 * generate the name for the error message explicitly. */
945                SV *stashname = sv_2mortal(newSV(0));
946                gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE);
947                DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"",
948                    methname, SVfARG(stashname));
949            }
950            else {
951                SV *stashname = !SvPOK(*MARK) ? &PL_sv_no
952                              : SvCUR(*MARK)  ? *MARK
953                              :                 sv_2mortal(newSVpvs("main"));
954                DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\""
955                    " (perhaps you forgot to load \"%" SVf "\"?)",
956                    methname, SVfARG(stashname), SVfARG(stashname));
957            }
958        }
959        else if (!(gv = gv_fetchmethod(stash, methname))) {
960            /* The effective name can only be NULL for stashes that have
961             * been deleted from the symbol table, which this one can't
962             * be, since we just looked it up by name.
963             */
964            DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"",
965                methname, HvENAME_HEK_NN(stash));
966        }
967         ENTER_with_name("call_TIE");
968         PUSHSTACKi(PERLSI_MAGIC);
969         PUSHMARK(SP);
970         EXTEND(SP,(I32)items);
971         while (items--)
972             PUSHs(*MARK++);
973         PUTBACK;
974         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
975     }
976     SPAGAIN;
977
978     sv = TOPs;
979     POPSTACK;
980     if (sv_isobject(sv)) {
981         sv_unmagic(varsv, how);
982         /* Croak if a self-tie on an aggregate is attempted. */
983         if (varsv == SvRV(sv) &&
984             (SvTYPE(varsv) == SVt_PVAV ||
985              SvTYPE(varsv) == SVt_PVHV))
986             Perl_croak(aTHX_
987                        "Self-ties of arrays and hashes are not supported");
988         sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
989     }
990     LEAVE_with_name("call_TIE");
991     SP = PL_stack_base + markoff;
992     PUSHs(sv);
993     RETURN;
994 }
995
996
997 /* also used for: pp_dbmclose() */
998
999 PP(pp_untie)
1000 {
1001     dSP;
1002     MAGIC *mg;
1003     SV *sv = POPs;
1004     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1005                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1006
1007     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1008         RETPUSHYES;
1009
1010     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1011         !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1012
1013     if ((mg = SvTIED_mg(sv, how))) {
1014         SV * const obj = SvRV(SvTIED_obj(sv, mg));
1015         if (obj && SvSTASH(obj)) {
1016             GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
1017             CV *cv;
1018             if (gv && isGV(gv) && (cv = GvCV(gv))) {
1019                PUSHMARK(SP);
1020                PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
1021                mXPUSHi(SvREFCNT(obj) - 1);
1022                PUTBACK;
1023                ENTER_with_name("call_UNTIE");
1024                call_sv(MUTABLE_SV(cv), G_VOID);
1025                LEAVE_with_name("call_UNTIE");
1026                SPAGAIN;
1027             }
1028             else if (mg && SvREFCNT(obj) > 1) {
1029                 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1030                                "untie attempted while %" UVuf " inner references still exist",
1031                                (UV)SvREFCNT(obj) - 1 ) ;
1032             }
1033         }
1034     }
1035     sv_unmagic(sv, how) ;
1036
1037     if (SvTYPE(sv) == SVt_PVHV) {
1038         /* If the tied hash was partway through iteration, free the iterator and
1039          * any key that it is pointing to. */
1040         HE *entry;
1041         if (HvLAZYDEL(sv) && (entry = HvEITER_get((HV *)sv))) {
1042             HvLAZYDEL_off(sv);
1043             hv_free_ent((HV *)sv, entry);
1044             HvEITER_set(MUTABLE_HV(sv), 0);
1045         }
1046     }
1047
1048     RETPUSHYES;
1049 }
1050
1051 PP(pp_tied)
1052 {
1053     dSP;
1054     const MAGIC *mg;
1055     dTOPss;
1056     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1057                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1058
1059     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1060         goto ret_undef;
1061
1062     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1063         !(sv = defelem_target(sv, NULL))) goto ret_undef;
1064
1065     if ((mg = SvTIED_mg(sv, how))) {
1066         SETs(SvTIED_obj(sv, mg));
1067         return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1068     }
1069     ret_undef:
1070     SETs(&PL_sv_undef);
1071     return NORMAL;
1072 }
1073
1074 PP(pp_dbmopen)
1075 {
1076     dSP;
1077     dPOPPOPssrl;
1078     HV* stash;
1079     GV *gv = NULL;
1080
1081     HV * const hv = MUTABLE_HV(POPs);
1082     SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1083     stash = gv_stashsv(sv, 0);
1084     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1085         PUTBACK;
1086         require_pv("AnyDBM_File.pm");
1087         SPAGAIN;
1088         if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1089             DIE(aTHX_ "No dbm on this machine");
1090     }
1091
1092     ENTER;
1093     PUSHMARK(SP);
1094
1095     EXTEND(SP, 5);
1096     PUSHs(sv);
1097     PUSHs(left);
1098     if (SvIV(right))
1099         mPUSHu(O_RDWR|O_CREAT);
1100     else
1101     {
1102         mPUSHu(O_RDWR);
1103         if (!SvOK(right)) right = &PL_sv_no;
1104     }
1105     PUSHs(right);
1106     PUTBACK;
1107     call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1108     SPAGAIN;
1109
1110     if (!sv_isobject(TOPs)) {
1111         SP--;
1112         PUSHMARK(SP);
1113         PUSHs(sv);
1114         PUSHs(left);
1115         mPUSHu(O_RDONLY);
1116         PUSHs(right);
1117         PUTBACK;
1118         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1119         SPAGAIN;
1120         if (sv_isobject(TOPs))
1121             goto retie;
1122     }
1123     else {
1124         retie:
1125         sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1126         sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1127     }
1128     LEAVE;
1129     RETURN;
1130 }
1131
1132 PP(pp_sselect)
1133 {
1134 #ifdef HAS_SELECT
1135     dSP; dTARGET;
1136     I32 i;
1137     I32 j;
1138     char *s;
1139     SV *sv;
1140     NV value;
1141     I32 maxlen = 0;
1142     I32 nfound;
1143     struct timeval timebuf;
1144     struct timeval *tbuf = &timebuf;
1145     I32 growsize;
1146     char *fd_sets[4];
1147     SV *svs[4];
1148 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1149         I32 masksize;
1150         I32 offset;
1151         I32 k;
1152
1153 #   if BYTEORDER & 0xf0000
1154 #       define ORDERBYTE (0x88888888 - BYTEORDER)
1155 #   else
1156 #       define ORDERBYTE (0x4444 - BYTEORDER)
1157 #   endif
1158
1159 #endif
1160
1161     SP -= 4;
1162     for (i = 1; i <= 3; i++) {
1163         SV * const sv = svs[i] = SP[i];
1164         SvGETMAGIC(sv);
1165         if (!SvOK(sv))
1166             continue;
1167         if (SvREADONLY(sv)) {
1168             if (!(SvPOK(sv) && SvCUR(sv) == 0))
1169                 Perl_croak_no_modify();
1170         }
1171         else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1172         if (!SvPOK(sv)) {
1173             if (!SvPOKp(sv))
1174                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1175                                     "Non-string passed as bitmask");
1176             if (SvGAMAGIC(sv)) {
1177                 svs[i] = sv_newmortal();
1178                 sv_copypv_nomg(svs[i], sv);
1179             }
1180             else
1181                 SvPV_force_nomg_nolen(sv); /* force string conversion */
1182         }
1183         j = SvCUR(svs[i]);
1184         if (maxlen < j)
1185             maxlen = j;
1186     }
1187
1188 /* little endians can use vecs directly */
1189 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1190 #  ifdef NFDBITS
1191
1192 #    ifndef NBBY
1193 #     define NBBY 8
1194 #    endif
1195
1196     masksize = NFDBITS / NBBY;
1197 #  else
1198     masksize = sizeof(long);    /* documented int, everyone seems to use long */
1199 #  endif
1200     Zero(&fd_sets[0], 4, char*);
1201 #endif
1202
1203 #  if SELECT_MIN_BITS == 1
1204     growsize = sizeof(fd_set);
1205 #  else
1206 #   if defined(__GLIBC__) && defined(__FD_SETSIZE)
1207 #      undef SELECT_MIN_BITS
1208 #      define SELECT_MIN_BITS __FD_SETSIZE
1209 #   endif
1210     /* If SELECT_MIN_BITS is greater than one we most probably will want
1211      * to align the sizes with SELECT_MIN_BITS/8 because for example
1212      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1213      * UNIX, Solaris, Darwin) the smallest quantum select() operates
1214      * on (sets/tests/clears bits) is 32 bits.  */
1215     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1216 #  endif
1217
1218     sv = SP[4];
1219     SvGETMAGIC(sv);
1220     if (SvOK(sv)) {
1221         value = SvNV_nomg(sv);
1222         if (value < 0.0)
1223             value = 0.0;
1224         timebuf.tv_sec = (long)value;
1225         value -= (NV)timebuf.tv_sec;
1226         timebuf.tv_usec = (long)(value * 1000000.0);
1227     }
1228     else
1229         tbuf = NULL;
1230
1231     for (i = 1; i <= 3; i++) {
1232         sv = svs[i];
1233         if (!SvOK(sv) || SvCUR(sv) == 0) {
1234             fd_sets[i] = 0;
1235             continue;
1236         }
1237         assert(SvPOK(sv));
1238         j = SvLEN(sv);
1239         if (j < growsize) {
1240             Sv_Grow(sv, growsize);
1241         }
1242         j = SvCUR(sv);
1243         s = SvPVX(sv) + j;
1244         while (++j <= growsize) {
1245             *s++ = '\0';
1246         }
1247
1248 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1249         s = SvPVX(sv);
1250         Newx(fd_sets[i], growsize, char);
1251         for (offset = 0; offset < growsize; offset += masksize) {
1252             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1253                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1254         }
1255 #else
1256         fd_sets[i] = SvPVX(sv);
1257 #endif
1258     }
1259
1260 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1261     /* Can't make just the (void*) conditional because that would be
1262      * cpp #if within cpp macro, and not all compilers like that. */
1263     nfound = PerlSock_select(
1264         maxlen * 8,
1265         (Select_fd_set_t) fd_sets[1],
1266         (Select_fd_set_t) fd_sets[2],
1267         (Select_fd_set_t) fd_sets[3],
1268         (void*) tbuf); /* Workaround for compiler bug. */
1269 #else
1270     nfound = PerlSock_select(
1271         maxlen * 8,
1272         (Select_fd_set_t) fd_sets[1],
1273         (Select_fd_set_t) fd_sets[2],
1274         (Select_fd_set_t) fd_sets[3],
1275         tbuf);
1276 #endif
1277     for (i = 1; i <= 3; i++) {
1278         if (fd_sets[i]) {
1279             sv = svs[i];
1280 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1281             s = SvPVX(sv);
1282             for (offset = 0; offset < growsize; offset += masksize) {
1283                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1284                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1285             }
1286             Safefree(fd_sets[i]);
1287 #endif
1288             if (sv != SP[i])
1289                 SvSetMagicSV(SP[i], sv);
1290             else
1291                 SvSETMAGIC(sv);
1292         }
1293     }
1294
1295     PUSHi(nfound);
1296     if (GIMME_V == G_LIST && tbuf) {
1297         value = (NV)(timebuf.tv_sec) +
1298                 (NV)(timebuf.tv_usec) / 1000000.0;
1299         mPUSHn(value);
1300     }
1301     RETURN;
1302 #else
1303     DIE(aTHX_ "select not implemented");
1304 #endif
1305 }
1306
1307 /*
1308
1309 =for apidoc_section $GV
1310
1311 =for apidoc setdefout
1312
1313 Sets C<PL_defoutgv>, the default file handle for output, to the passed in
1314 typeglob.  As C<PL_defoutgv> "owns" a reference on its typeglob, the reference
1315 count of the passed in typeglob is increased by one, and the reference count
1316 of the typeglob that C<PL_defoutgv> points to is decreased by one.
1317
1318 =cut
1319 */
1320
1321 void
1322 Perl_setdefout(pTHX_ GV *gv)
1323 {
1324     GV *oldgv = PL_defoutgv;
1325
1326     PERL_ARGS_ASSERT_SETDEFOUT;
1327
1328     SvREFCNT_inc_simple_void_NN(gv);
1329     PL_defoutgv = gv;
1330     SvREFCNT_dec(oldgv);
1331 }
1332
1333 PP(pp_select)
1334 {
1335     dSP; dTARGET;
1336     HV *hv;
1337     GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1338     GV * egv = GvEGVx(PL_defoutgv);
1339     GV * const *gvp;
1340
1341     if (!egv)
1342         egv = PL_defoutgv;
1343     hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1344     gvp = hv && HvENAME(hv)
1345                 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1346                 : NULL;
1347     if (gvp && *gvp == egv) {
1348             gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1349             XPUSHTARG;
1350     }
1351     else {
1352             mXPUSHs(newRV(MUTABLE_SV(egv)));
1353     }
1354
1355     if (newdefout) {
1356         if (!GvIO(newdefout))
1357             gv_IOadd(newdefout);
1358         setdefout(newdefout);
1359     }
1360
1361     RETURN;
1362 }
1363
1364 PP(pp_getc)
1365 {
1366     dSP; dTARGET;
1367     /* pp_coreargs pushes a NULL to indicate no args passed to
1368      * CORE::getc() */
1369     GV * const gv =
1370         MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1371     IO *const io = GvIO(gv);
1372
1373     if (MAXARG == 0)
1374         EXTEND(SP, 1);
1375
1376     if (io) {
1377         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1378         if (mg) {
1379             const U8 gimme = GIMME_V;
1380             Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1381             if (gimme == G_SCALAR) {
1382                 SPAGAIN;
1383                 SvSetMagicSV_nosteal(TARG, TOPs);
1384             }
1385             return NORMAL;
1386         }
1387     }
1388     if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1389         if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1390             report_evil_fh(gv);
1391         SETERRNO(EBADF,RMS_IFI);
1392         RETPUSHUNDEF;
1393     }
1394     TAINT;
1395     sv_setpvs(TARG, " ");
1396     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1397     if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1398         /* Find out how many bytes the char needs */
1399         Size_t len = UTF8SKIP(SvPVX_const(TARG));
1400         if (len > 1) {
1401             SvGROW(TARG,len+1);
1402             len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1403             SvCUR_set(TARG,1+len);
1404         }
1405         SvUTF8_on(TARG);
1406     }
1407     else SvUTF8_off(TARG);
1408     PUSHTARG;
1409     RETURN;
1410 }
1411
1412 STATIC OP *
1413 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1414 {
1415     PERL_CONTEXT *cx;
1416     const U8 gimme = GIMME_V;
1417
1418     PERL_ARGS_ASSERT_DOFORM;
1419
1420     if (CvCLONE(cv))
1421         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1422
1423     cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix);
1424     cx_pushformat(cx, cv, retop, gv);
1425     if (CvDEPTH(cv) >= 2)
1426         pad_push(CvPADLIST(cv), CvDEPTH(cv));
1427     PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1428
1429     setdefout(gv);          /* locally select filehandle so $% et al work */
1430     return CvSTART(cv);
1431 }
1432
1433 PP(pp_enterwrite)
1434 {
1435     dSP;
1436     GV *gv;
1437     IO *io;
1438     GV *fgv;
1439     CV *cv = NULL;
1440
1441     if (MAXARG == 0) {
1442         EXTEND(SP, 1);
1443         gv = PL_defoutgv;
1444     }
1445     else {
1446         gv = MUTABLE_GV(POPs);
1447         if (!gv)
1448             gv = PL_defoutgv;
1449     }
1450     io = GvIO(gv);
1451     if (!io) {
1452         RETPUSHNO;
1453     }
1454     if (IoFMT_GV(io))
1455         fgv = IoFMT_GV(io);
1456     else
1457         fgv = gv;
1458
1459     assert(fgv);
1460
1461     cv = GvFORM(fgv);
1462     if (!cv) {
1463         SV * const tmpsv = sv_newmortal();
1464         gv_efullname4(tmpsv, fgv, NULL, FALSE);
1465         DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv));
1466     }
1467     IoFLAGS(io) &= ~IOf_DIDTOP;
1468     RETURNOP(doform(cv,gv,PL_op->op_next));
1469 }
1470
1471 PP(pp_leavewrite)
1472 {
1473     dSP;
1474     GV * const gv = CX_CUR()->blk_format.gv;
1475     IO * const io = GvIOp(gv);
1476     PerlIO *ofp;
1477     PerlIO *fp;
1478     PERL_CONTEXT *cx;
1479     OP *retop;
1480     bool is_return = cBOOL(PL_op->op_type == OP_RETURN);
1481
1482     if (is_return || !io || !(ofp = IoOFP(io)))
1483         goto forget_top;
1484
1485     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1486           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1487
1488     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1489         PL_formtarget != PL_toptarget)
1490     {
1491         GV *fgv;
1492         CV *cv;
1493         if (!IoTOP_GV(io)) {
1494             GV *topgv;
1495
1496             if (!IoTOP_NAME(io)) {
1497                 SV *topname;
1498                 if (!IoFMT_NAME(io))
1499                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1500                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP",
1501                                         HEKfARG(GvNAME_HEK(gv))));
1502                 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1503                 if ((topgv && GvFORM(topgv)) ||
1504                   !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1505                     IoTOP_NAME(io) = savesvpv(topname);
1506                 else
1507                     IoTOP_NAME(io) = savepvs("top");
1508             }
1509             topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1510             if (!topgv || !GvFORM(topgv)) {
1511                 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1512                 goto forget_top;
1513             }
1514             IoTOP_GV(io) = topgv;
1515         }
1516         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1517             I32 lines = IoLINES_LEFT(io);
1518             const char *s = SvPVX_const(PL_formtarget);
1519             const char *e = SvEND(PL_formtarget);
1520             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1521                 goto forget_top;
1522             while (lines-- > 0) {
1523                 s = (char *) memchr(s, '\n', e - s);
1524                 if (!s)
1525                     break;
1526                 s++;
1527             }
1528             if (s) {
1529                 const STRLEN save = SvCUR(PL_formtarget);
1530                 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1531                 do_print(PL_formtarget, ofp);
1532                 SvCUR_set(PL_formtarget, save);
1533                 sv_chop(PL_formtarget, s);
1534                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1535             }
1536         }
1537         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1538             do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1539         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1540         IoPAGE(io)++;
1541         PL_formtarget = PL_toptarget;
1542         IoFLAGS(io) |= IOf_DIDTOP;
1543         fgv = IoTOP_GV(io);
1544         assert(fgv); /* IoTOP_GV(io) should have been set above */
1545         cv = GvFORM(fgv);
1546         if (!cv) {
1547             SV * const sv = sv_newmortal();
1548             gv_efullname4(sv, fgv, NULL, FALSE);
1549             DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv));
1550         }
1551         return doform(cv, gv, PL_op);
1552     }
1553
1554   forget_top:
1555     cx = CX_CUR();
1556     assert(CxTYPE(cx) == CXt_FORMAT);
1557     SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */
1558     CX_LEAVE_SCOPE(cx);
1559     cx_popformat(cx);
1560     cx_popblock(cx);
1561     retop = cx->blk_sub.retop;
1562     CX_POP(cx);
1563
1564     EXTEND(SP, 1);
1565
1566     if (is_return)
1567         /* XXX the semantics of doing 'return' in a format aren't documented.
1568          * Currently we ignore any args to 'return' and just return
1569          * a single undef in both scalar and list contexts
1570          */
1571         PUSHs(&PL_sv_undef);
1572     else if (!io || !(fp = IoOFP(io))) {
1573         if (io && IoIFP(io))
1574             report_wrongway_fh(gv, '<');
1575         else
1576             report_evil_fh(gv);
1577         PUSHs(&PL_sv_no);
1578     }
1579     else {
1580         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1581             Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1582         }
1583         if (!do_print(PL_formtarget, fp))
1584             PUSHs(&PL_sv_no);
1585         else {
1586             FmLINES(PL_formtarget) = 0;
1587             SvCUR_set(PL_formtarget, 0);
1588             *SvEND(PL_formtarget) = '\0';
1589             if (IoFLAGS(io) & IOf_FLUSH)
1590                 (void)PerlIO_flush(fp);
1591             PUSHs(&PL_sv_yes);
1592         }
1593     }
1594     PL_formtarget = PL_bodytarget;
1595     RETURNOP(retop);
1596 }
1597
1598 PP(pp_prtf)
1599 {
1600     dSP; dMARK; dORIGMARK;
1601     PerlIO *fp;
1602
1603     GV * const gv
1604         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1605     IO *const io = GvIO(gv);
1606
1607     /* Treat empty list as "" */
1608     if (MARK == SP) XPUSHs(&PL_sv_no);
1609
1610     if (io) {
1611         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1612         if (mg) {
1613             if (MARK == ORIGMARK) {
1614                 MEXTEND(SP, 1);
1615                 ++MARK;
1616                 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1617                 ++SP;
1618             }
1619             return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1620                                     mg,
1621                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1622                                     sp - mark);
1623         }
1624     }
1625
1626     if (!io) {
1627         report_evil_fh(gv);
1628         SETERRNO(EBADF,RMS_IFI);
1629         goto just_say_no;
1630     }
1631     else if (!(fp = IoOFP(io))) {
1632         if (IoIFP(io))
1633             report_wrongway_fh(gv, '<');
1634         else if (ckWARN(WARN_CLOSED))
1635             report_evil_fh(gv);
1636         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1637         goto just_say_no;
1638     }
1639     else {
1640         SV *sv = sv_newmortal();
1641         do_sprintf(sv, SP - MARK, MARK + 1);
1642         if (!do_print(sv, fp))
1643             goto just_say_no;
1644
1645         if (IoFLAGS(io) & IOf_FLUSH)
1646             if (PerlIO_flush(fp) == EOF)
1647                 goto just_say_no;
1648     }
1649     SP = ORIGMARK;
1650     PUSHs(&PL_sv_yes);
1651     RETURN;
1652
1653   just_say_no:
1654     SP = ORIGMARK;
1655     PUSHs(&PL_sv_undef);
1656     RETURN;
1657 }
1658
1659 PP(pp_sysopen)
1660 {
1661     dSP;
1662     const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1663     const int mode = POPi;
1664     SV * const sv = POPs;
1665     GV * const gv = MUTABLE_GV(POPs);
1666     STRLEN len;
1667
1668     /* Need TIEHANDLE method ? */
1669     const char * const tmps = SvPV_const(sv, len);
1670     if (do_open_raw(gv, tmps, len, mode, perm, NULL)) {
1671         IoLINES(GvIOp(gv)) = 0;
1672         PUSHs(&PL_sv_yes);
1673     }
1674     else {
1675         PUSHs(&PL_sv_undef);
1676     }
1677     RETURN;
1678 }
1679
1680
1681 /* also used for: pp_read() and pp_recv() (where supported) */
1682
1683 PP(pp_sysread)
1684 {
1685     dSP; dMARK; dORIGMARK; dTARGET;
1686     SSize_t offset;
1687     IO *io;
1688     char *buffer;
1689     STRLEN orig_size;
1690     SSize_t length;
1691     SSize_t count;
1692     SV *bufsv;
1693     STRLEN blen;
1694     int fp_utf8;
1695     int buffer_utf8;
1696     SV *read_target;
1697     Size_t got = 0;
1698     Size_t wanted;
1699     bool charstart = FALSE;
1700     STRLEN charskip = 0;
1701     STRLEN skip = 0;
1702     GV * const gv = MUTABLE_GV(*++MARK);
1703     int fd;
1704
1705     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1706         && gv && (io = GvIO(gv)) )
1707     {
1708         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1709         if (mg) {
1710             return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1711                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1712                                     sp - mark);
1713         }
1714     }
1715
1716     if (!gv)
1717         goto say_undef;
1718     bufsv = *++MARK;
1719     if (! SvOK(bufsv))
1720         SvPVCLEAR(bufsv);
1721     length = SvIVx(*++MARK);
1722     if (length < 0)
1723         DIE(aTHX_ "Negative length");
1724     SETERRNO(0,0);
1725     if (MARK < SP)
1726         offset = SvIVx(*++MARK);
1727     else
1728         offset = 0;
1729     io = GvIO(gv);
1730     if (!io || !IoIFP(io)) {
1731         report_evil_fh(gv);
1732         SETERRNO(EBADF,RMS_IFI);
1733         goto say_undef;
1734     }
1735
1736     /* Note that fd can here validly be -1, don't check it yet. */
1737     fd = PerlIO_fileno(IoIFP(io));
1738
1739     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1740         if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) {
1741             Perl_croak(aTHX_
1742                        "%s() isn't allowed on :utf8 handles",
1743                        OP_DESC(PL_op));
1744         }
1745         buffer = SvPVutf8_force(bufsv, blen);
1746         /* UTF-8 may not have been set if they are all low bytes */
1747         SvUTF8_on(bufsv);
1748         buffer_utf8 = 0;
1749     }
1750     else {
1751         buffer = SvPV_force(bufsv, blen);
1752         buffer_utf8 = DO_UTF8(bufsv);
1753     }
1754     if (DO_UTF8(bufsv)) {
1755         blen = sv_len_utf8_nomg(bufsv);
1756     }
1757
1758     charstart = TRUE;
1759     charskip  = 0;
1760     skip = 0;
1761     wanted = length;
1762
1763 #ifdef HAS_SOCKET
1764     if (PL_op->op_type == OP_RECV) {
1765         Sock_size_t bufsize;
1766         char namebuf[MAXPATHLEN];
1767         if (fd < 0) {
1768             SETERRNO(EBADF,SS_IVCHAN);
1769             goto say_undef;
1770         }
1771 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1772         bufsize = sizeof (struct sockaddr_in);
1773 #else
1774         bufsize = sizeof namebuf;
1775 #endif
1776 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1777         if (bufsize >= 256)
1778             bufsize = 255;
1779 #endif
1780         buffer = SvGROW(bufsv, (STRLEN)(length+1));
1781         /* 'offset' means 'flags' here */
1782         count = PerlSock_recvfrom(fd, buffer, length, offset,
1783                                   (struct sockaddr *)namebuf, &bufsize);
1784         if (count < 0)
1785             goto say_undef;
1786         /* MSG_TRUNC can give oversized count; quietly lose it */
1787         if (count > length)
1788             count = length;
1789         SvCUR_set(bufsv, count);
1790         *SvEND(bufsv) = '\0';
1791         (void)SvPOK_only(bufsv);
1792         if (fp_utf8)
1793             SvUTF8_on(bufsv);
1794         SvSETMAGIC(bufsv);
1795         /* This should not be marked tainted if the fp is marked clean */
1796         if (!(IoFLAGS(io) & IOf_UNTAINT))
1797             SvTAINTED_on(bufsv);
1798         SP = ORIGMARK;
1799 #if defined(__CYGWIN__)
1800         /* recvfrom() on cygwin doesn't set bufsize at all for
1801            connected sockets, leaving us with trash in the returned
1802            name, so use the same test as the Win32 code to check if it
1803            wasn't set, and set it [perl #118843] */
1804         if (bufsize == sizeof namebuf)
1805             bufsize = 0;
1806 #endif
1807         sv_setpvn(TARG, namebuf, bufsize);
1808         PUSHs(TARG);
1809         RETURN;
1810     }
1811 #endif
1812     if (offset < 0) {
1813         if (-offset > (SSize_t)blen)
1814             DIE(aTHX_ "Offset outside string");
1815         offset += blen;
1816     }
1817     if (DO_UTF8(bufsv)) {
1818         /* convert offset-as-chars to offset-as-bytes */
1819         if (offset >= (SSize_t)blen)
1820             offset += SvCUR(bufsv) - blen;
1821         else
1822             offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1823     }
1824
1825  more_bytes:
1826     /* Reestablish the fd in case it shifted from underneath us. */
1827     fd = PerlIO_fileno(IoIFP(io));
1828
1829     orig_size = SvCUR(bufsv);
1830     /* Allocating length + offset + 1 isn't perfect in the case of reading
1831        bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1832        unduly.
1833        (should be 2 * length + offset + 1, or possibly something longer if
1834        IN_ENCODING Is true) */
1835     buffer  = SvGROW(bufsv, (STRLEN)(length+offset+1));
1836     if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1837         Zero(buffer+orig_size, offset-orig_size, char);
1838     }
1839     buffer = buffer + offset;
1840     if (!buffer_utf8) {
1841         read_target = bufsv;
1842     } else {
1843         /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1844            concatenate it to the current buffer.  */
1845
1846         /* Truncate the existing buffer to the start of where we will be
1847            reading to:  */
1848         SvCUR_set(bufsv, offset);
1849
1850         read_target = sv_newmortal();
1851         SvUPGRADE(read_target, SVt_PV);
1852         buffer = SvGROW(read_target, (STRLEN)(length + 1));
1853     }
1854
1855     if (PL_op->op_type == OP_SYSREAD) {
1856 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1857         if (IoTYPE(io) == IoTYPE_SOCKET) {
1858             if (fd < 0) {
1859                 SETERRNO(EBADF,SS_IVCHAN);
1860                 count = -1;
1861             }
1862             else
1863                 count = PerlSock_recv(fd, buffer, length, 0);
1864         }
1865         else
1866 #endif
1867         {
1868             if (fd < 0) {
1869                 SETERRNO(EBADF,RMS_IFI);
1870                 count = -1;
1871             }
1872             else
1873                 count = PerlLIO_read(fd, buffer, length);
1874         }
1875     }
1876     else
1877     {
1878         count = PerlIO_read(IoIFP(io), buffer, length);
1879         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1880         if (count == 0 && PerlIO_error(IoIFP(io)))
1881             count = -1;
1882     }
1883     if (count < 0) {
1884         if (IoTYPE(io) == IoTYPE_WRONLY)
1885             report_wrongway_fh(gv, '>');
1886         goto say_undef;
1887     }
1888     SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1889     *SvEND(read_target) = '\0';
1890     (void)SvPOK_only(read_target);
1891     if (fp_utf8 && !IN_BYTES) {
1892         /* Look at utf8 we got back and count the characters */
1893         const char *bend = buffer + count;
1894         while (buffer < bend) {
1895             if (charstart) {
1896                 skip = UTF8SKIP(buffer);
1897                 charskip = 0;
1898             }
1899             if (buffer - charskip + skip > bend) {
1900                 /* partial character - try for rest of it */
1901                 length = skip - (bend-buffer);
1902                 offset = bend - SvPVX_const(bufsv);
1903                 charstart = FALSE;
1904                 charskip += count;
1905                 goto more_bytes;
1906             }
1907             else {
1908                 got++;
1909                 buffer += skip;
1910                 charstart = TRUE;
1911                 charskip  = 0;
1912             }
1913         }
1914         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1915            provided amount read (count) was what was requested (length)
1916          */
1917         if (got < wanted && count == length) {
1918             length = wanted - got;
1919             offset = bend - SvPVX_const(bufsv);
1920             goto more_bytes;
1921         }
1922         /* return value is character count */
1923         count = got;
1924         SvUTF8_on(bufsv);
1925     }
1926     else if (buffer_utf8) {
1927         /* Let svcatsv upgrade the bytes we read in to utf8.
1928            The buffer is a mortal so will be freed soon.  */
1929         sv_catsv_nomg(bufsv, read_target);
1930     }
1931     SvSETMAGIC(bufsv);
1932     /* This should not be marked tainted if the fp is marked clean */
1933     if (!(IoFLAGS(io) & IOf_UNTAINT))
1934         SvTAINTED_on(bufsv);
1935     SP = ORIGMARK;
1936     PUSHi(count);
1937     RETURN;
1938
1939   say_undef:
1940     SP = ORIGMARK;
1941     RETPUSHUNDEF;
1942 }
1943
1944
1945 /* also used for: pp_send() where defined */
1946
1947 PP(pp_syswrite)
1948 {
1949     dSP; dMARK; dORIGMARK; dTARGET;
1950     SV *bufsv;
1951     const char *buffer;
1952     SSize_t retval;
1953     STRLEN blen;
1954     const int op_type = PL_op->op_type;
1955     bool doing_utf8;
1956     U8 *tmpbuf = NULL;
1957     GV *const gv = MUTABLE_GV(*++MARK);
1958     IO *const io = GvIO(gv);
1959     int fd;
1960
1961     if (op_type == OP_SYSWRITE && io) {
1962         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1963         if (mg) {
1964             if (MARK == SP - 1) {
1965                 SV *sv = *SP;
1966                 mXPUSHi(sv_len(sv));
1967                 PUTBACK;
1968             }
1969
1970             return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1971                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1972                                     sp - mark);
1973         }
1974     }
1975     if (!gv)
1976         goto say_undef;
1977
1978     bufsv = *++MARK;
1979
1980     SETERRNO(0,0);
1981     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1982         retval = -1;
1983         if (io && IoIFP(io))
1984             report_wrongway_fh(gv, '<');
1985         else
1986             report_evil_fh(gv);
1987         SETERRNO(EBADF,RMS_IFI);
1988         goto say_undef;
1989     }
1990     fd = PerlIO_fileno(IoIFP(io));
1991     if (fd < 0) {
1992         SETERRNO(EBADF,SS_IVCHAN);
1993         retval = -1;
1994         goto say_undef;
1995     }
1996
1997     /* Do this first to trigger any overloading.  */
1998     buffer = SvPV_const(bufsv, blen);
1999     doing_utf8 = DO_UTF8(bufsv);
2000
2001     if (PerlIO_isutf8(IoIFP(io))) {
2002         Perl_croak(aTHX_
2003                    "%s() isn't allowed on :utf8 handles",
2004                    OP_DESC(PL_op));
2005     }
2006     else if (doing_utf8) {
2007         STRLEN tmplen = blen;
2008         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
2009         if (!doing_utf8) {
2010             tmpbuf = result;
2011             buffer = (char *) tmpbuf;
2012             blen = tmplen;
2013         }
2014         else {
2015             assert((char *)result == buffer);
2016             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
2017         }
2018     }
2019
2020 #ifdef HAS_SOCKET
2021     if (op_type == OP_SEND) {
2022         const int flags = SvIVx(*++MARK);
2023         if (SP > MARK) {
2024             STRLEN mlen;
2025             char * const sockbuf = SvPVx(*++MARK, mlen);
2026             retval = PerlSock_sendto(fd, buffer, blen,
2027                                      flags, (struct sockaddr *)sockbuf, mlen);
2028         }
2029         else {
2030             retval = PerlSock_send(fd, buffer, blen, flags);
2031         }
2032     }
2033     else
2034 #endif
2035     {
2036         Size_t length = 0; /* This length is in characters.  */
2037         IV offset;
2038
2039         if (MARK >= SP) {
2040             length = blen;
2041         } else {
2042 #if Size_t_size > IVSIZE
2043             length = (Size_t)SvNVx(*++MARK);
2044 #else
2045             length = (Size_t)SvIVx(*++MARK);
2046 #endif
2047             if ((SSize_t)length < 0) {
2048                 Safefree(tmpbuf);
2049                 DIE(aTHX_ "Negative length");
2050             }
2051         }
2052
2053         if (MARK < SP) {
2054             offset = SvIVx(*++MARK);
2055             if (offset < 0) {
2056                 if (-offset > (IV)blen) {
2057                     Safefree(tmpbuf);
2058                     DIE(aTHX_ "Offset outside string");
2059                 }
2060                 offset += blen;
2061             } else if (offset > (IV)blen) {
2062                 Safefree(tmpbuf);
2063                 DIE(aTHX_ "Offset outside string");
2064             }
2065         } else
2066             offset = 0;
2067         if (length > blen - offset)
2068             length = blen - offset;
2069         buffer = buffer+offset;
2070
2071 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2072         if (IoTYPE(io) == IoTYPE_SOCKET) {
2073             retval = PerlSock_send(fd, buffer, length, 0);
2074         }
2075         else
2076 #endif
2077         {
2078             /* See the note at doio.c:do_print about filesize limits. --jhi */
2079             retval = PerlLIO_write(fd, buffer, length);
2080         }
2081     }
2082
2083     if (retval < 0)
2084         goto say_undef;
2085     SP = ORIGMARK;
2086
2087     Safefree(tmpbuf);
2088 #if Size_t_size > IVSIZE
2089     PUSHn(retval);
2090 #else
2091     PUSHi(retval);
2092 #endif
2093     RETURN;
2094
2095   say_undef:
2096     Safefree(tmpbuf);
2097     SP = ORIGMARK;
2098     RETPUSHUNDEF;
2099 }
2100
2101 PP(pp_eof)
2102 {
2103     dSP;
2104     GV *gv;
2105     IO *io;
2106     const MAGIC *mg;
2107     /*
2108      * in Perl 5.12 and later, the additional parameter is a bitmask:
2109      * 0 = eof
2110      * 1 = eof(FH)
2111      * 2 = eof()  <- ARGV magic
2112      *
2113      * I'll rely on the compiler's trace flow analysis to decide whether to
2114      * actually assign this out here, or punt it into the only block where it is
2115      * used. Doing it out here is DRY on the condition logic.
2116      */
2117     unsigned int which;
2118
2119     if (MAXARG) {
2120         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2121         which = 1;
2122     }
2123     else {
2124         EXTEND(SP, 1);
2125
2126         if (PL_op->op_flags & OPf_SPECIAL) {
2127             gv = PL_last_in_gv = GvEGVx(PL_argvgv);     /* eof() - ARGV magic */
2128             which = 2;
2129         }
2130         else {
2131             gv = PL_last_in_gv;                 /* eof */
2132             which = 0;
2133         }
2134     }
2135
2136     if (!gv)
2137         RETPUSHYES;
2138
2139     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2140         return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2141     }
2142
2143     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {   /* eof() */
2144         if (io && !IoIFP(io)) {
2145             if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) {
2146                 SV ** svp;
2147                 IoLINES(io) = 0;
2148                 IoFLAGS(io) &= ~IOf_START;
2149                 do_open6(gv, "-", 1, NULL, NULL, 0);
2150                 svp = &GvSV(gv);
2151                 if (*svp) {
2152                     SV * sv = *svp;
2153                     sv_setpvs(sv, "-");
2154                     SvSETMAGIC(sv);
2155                 }
2156                 else
2157                     *svp = newSVpvs("-");
2158             }
2159             else if (!nextargv(gv, FALSE))
2160                 RETPUSHYES;
2161         }
2162     }
2163
2164     PUSHs(boolSV(do_eof(gv)));
2165     RETURN;
2166 }
2167
2168 PP(pp_tell)
2169 {
2170     dSP; dTARGET;
2171     GV *gv;
2172     IO *io;
2173
2174     if (MAXARG != 0 && (TOPs || POPs))
2175         PL_last_in_gv = MUTABLE_GV(POPs);
2176     else
2177         EXTEND(SP, 1);
2178     gv = PL_last_in_gv;
2179
2180     io = GvIO(gv);
2181     if (io) {
2182         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2183         if (mg) {
2184             return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2185         }
2186     }
2187     else if (!gv) {
2188         if (!errno)
2189             SETERRNO(EBADF,RMS_IFI);
2190         PUSHi(-1);
2191         RETURN;
2192     }
2193
2194 #if LSEEKSIZE > IVSIZE
2195     PUSHn( (NV)do_tell(gv) );
2196 #else
2197     PUSHi( (IV)do_tell(gv) );
2198 #endif
2199     RETURN;
2200 }
2201
2202
2203 /* also used for: pp_seek() */
2204
2205 PP(pp_sysseek)
2206 {
2207     dSP;
2208     const int whence = POPi;
2209 #if LSEEKSIZE > IVSIZE
2210     const Off_t offset = (Off_t)SvNVx(POPs);
2211 #else
2212     const Off_t offset = (Off_t)SvIVx(POPs);
2213 #endif
2214
2215     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2216     IO *const io = GvIO(gv);
2217
2218     if (io) {
2219         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2220         if (mg) {
2221 #if LSEEKSIZE > IVSIZE
2222             SV *const offset_sv = newSVnv((NV) offset);
2223 #else
2224             SV *const offset_sv = newSViv(offset);
2225 #endif
2226
2227             return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2228                                 newSViv(whence));
2229         }
2230     }
2231
2232     if (PL_op->op_type == OP_SEEK)
2233         PUSHs(boolSV(do_seek(gv, offset, whence)));
2234     else {
2235         const Off_t sought = do_sysseek(gv, offset, whence);
2236         if (sought < 0)
2237             PUSHs(&PL_sv_undef);
2238         else {
2239             SV* const sv = sought ?
2240 #if LSEEKSIZE > IVSIZE
2241                 newSVnv((NV)sought)
2242 #else
2243                 newSViv(sought)
2244 #endif
2245                 : newSVpvn(zero_but_true, ZBTLEN);
2246             mPUSHs(sv);
2247         }
2248     }
2249     RETURN;
2250 }
2251
2252 PP(pp_truncate)
2253 {
2254     dSP;
2255     /* There seems to be no consensus on the length type of truncate()
2256      * and ftruncate(), both off_t and size_t have supporters. In
2257      * general one would think that when using large files, off_t is
2258      * at least as wide as size_t, so using an off_t should be okay. */
2259     /* XXX Configure probe for the length type of *truncate() needed XXX */
2260     Off_t len;
2261
2262 #if Off_t_size > IVSIZE
2263     len = (Off_t)POPn;
2264 #else
2265     len = (Off_t)POPi;
2266 #endif
2267     /* Checking for length < 0 is problematic as the type might or
2268      * might not be signed: if it is not, clever compilers will moan. */
2269     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2270     SETERRNO(0,0);
2271     {
2272         SV * const sv = POPs;
2273         int result = 1;
2274         GV *tmpgv;
2275         IO *io;
2276
2277         if (PL_op->op_flags & OPf_SPECIAL
2278                        ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2279                        : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2280             io = GvIO(tmpgv);
2281             if (!io)
2282                 result = 0;
2283             else {
2284                 PerlIO *fp;
2285             do_ftruncate_io:
2286                 TAINT_PROPER("truncate");
2287                 if (!(fp = IoIFP(io))) {
2288                     result = 0;
2289                 }
2290                 else {
2291                     int fd = PerlIO_fileno(fp);
2292                     if (fd < 0) {
2293                         SETERRNO(EBADF,RMS_IFI);
2294                         result = 0;
2295                     } else {
2296                         if (len < 0) {
2297                             SETERRNO(EINVAL, LIB_INVARG);
2298                             result = 0;
2299                         } else {
2300                            PerlIO_flush(fp);
2301 #ifdef HAS_TRUNCATE
2302                            if (ftruncate(fd, len) < 0)
2303 #else
2304                            if (my_chsize(fd, len) < 0)
2305 #endif
2306                                result = 0;
2307                         }
2308                     }
2309                 }
2310             }
2311         }
2312         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2313                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2314                 goto do_ftruncate_io;
2315         }
2316         else {
2317             const char * const name = SvPV_nomg_const_nolen(sv);
2318             TAINT_PROPER("truncate");
2319 #ifdef HAS_TRUNCATE
2320             if (truncate(name, len) < 0)
2321                 result = 0;
2322 #else
2323             {
2324                 int mode = O_RDWR;
2325                 int tmpfd;
2326
2327 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2328                 mode |= O_LARGEFILE;    /* Transparently largefiley. */
2329 #endif
2330 #ifdef O_BINARY
2331                 /* On open(), the Win32 CRT tries to seek around text
2332                  * files using 32-bit offsets, which causes the open()
2333                  * to fail on large files, so open in binary mode.
2334                  */
2335                 mode |= O_BINARY;
2336 #endif
2337                 tmpfd = PerlLIO_open_cloexec(name, mode);
2338
2339                 if (tmpfd < 0) {
2340                     result = 0;
2341                 } else {
2342                     if (my_chsize(tmpfd, len) < 0)
2343                         result = 0;
2344                     PerlLIO_close(tmpfd);
2345                 }
2346             }
2347 #endif
2348         }
2349
2350         if (result)
2351             RETPUSHYES;
2352         if (!errno)
2353             SETERRNO(EBADF,RMS_IFI);
2354         RETPUSHUNDEF;
2355     }
2356 }
2357
2358
2359 /* also used for: pp_fcntl() */
2360
2361 PP(pp_ioctl)
2362 {
2363     dSP; dTARGET;
2364     SV * const argsv = POPs;
2365     const unsigned int func = POPu;
2366     int optype;
2367     GV * const gv = MUTABLE_GV(POPs);
2368     IO * const io = GvIOn(gv);
2369     char *s;
2370     IV retval;
2371
2372     if (!IoIFP(io)) {
2373         report_evil_fh(gv);
2374         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2375         RETPUSHUNDEF;
2376     }
2377
2378     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2379         STRLEN len;
2380         STRLEN need;
2381         s = SvPV_force(argsv, len);
2382         need = IOCPARM_LEN(func);
2383         if (len < need) {
2384             s = Sv_Grow(argsv, need + 1);
2385             SvCUR_set(argsv, need);
2386         }
2387
2388         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2389     }
2390     else {
2391         retval = SvIV(argsv);
2392         s = INT2PTR(char*,retval);              /* ouch */
2393     }
2394
2395     optype = PL_op->op_type;
2396     TAINT_PROPER(PL_op_desc[optype]);
2397
2398     if (optype == OP_IOCTL)
2399 #ifdef HAS_IOCTL
2400         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2401 #else
2402         DIE(aTHX_ "ioctl is not implemented");
2403 #endif
2404     else
2405 #ifndef HAS_FCNTL
2406       DIE(aTHX_ "fcntl is not implemented");
2407 #elif defined(OS2) && defined(__EMX__)
2408         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2409 #else
2410         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2411 #endif
2412
2413 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2414     if (SvPOK(argsv)) {
2415         if (s[SvCUR(argsv)] != 17)
2416             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2417                 OP_NAME(PL_op));
2418         s[SvCUR(argsv)] = 0;            /* put our null back */
2419         SvSETMAGIC(argsv);              /* Assume it has changed */
2420     }
2421
2422     if (retval == -1)
2423         RETPUSHUNDEF;
2424     if (retval != 0) {
2425         PUSHi(retval);
2426     }
2427     else {
2428         PUSHp(zero_but_true, ZBTLEN);
2429     }
2430 #endif
2431     RETURN;
2432 }
2433
2434 PP(pp_flock)
2435 {
2436 #ifdef FLOCK
2437     dSP; dTARGET;
2438     I32 value;
2439     const int argtype = POPi;
2440     GV * const gv = MUTABLE_GV(POPs);
2441     IO *const io = GvIO(gv);
2442     PerlIO *const fp = io ? IoIFP(io) : NULL;
2443
2444     /* XXX Looks to me like io is always NULL at this point */
2445     if (fp) {
2446         (void)PerlIO_flush(fp);
2447         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2448     }
2449     else {
2450         report_evil_fh(gv);
2451         value = 0;
2452         SETERRNO(EBADF,RMS_IFI);
2453     }
2454     PUSHi(value);
2455     RETURN;
2456 #else
2457     DIE(aTHX_ PL_no_func, "flock");
2458 #endif
2459 }
2460
2461 /* Sockets. */
2462
2463 #ifdef HAS_SOCKET
2464
2465 PP(pp_socket)
2466 {
2467     dSP;
2468     const int protocol = POPi;
2469     const int type = POPi;
2470     const int domain = POPi;
2471     GV * const gv = MUTABLE_GV(POPs);
2472     IO * const io = GvIOn(gv);
2473     int fd;
2474
2475     if (IoIFP(io))
2476         do_close(gv, FALSE);
2477
2478     TAINT_PROPER("socket");
2479     fd = PerlSock_socket_cloexec(domain, type, protocol);
2480     if (fd < 0) {
2481         RETPUSHUNDEF;
2482     }
2483     IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2484     IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2485     IoTYPE(io) = IoTYPE_SOCKET;
2486     if (!IoIFP(io) || !IoOFP(io)) {
2487         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2488         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2489         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2490         RETPUSHUNDEF;
2491     }
2492
2493     RETPUSHYES;
2494 }
2495 #endif
2496
2497 PP(pp_sockpair)
2498 {
2499 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2500     dSP;
2501     int fd[2];
2502     const int protocol = POPi;
2503     const int type = POPi;
2504     const int domain = POPi;
2505
2506     GV * const gv2 = MUTABLE_GV(POPs);
2507     IO * const io2 = GvIOn(gv2);
2508     GV * const gv1 = MUTABLE_GV(POPs);
2509     IO * const io1 = GvIOn(gv1);
2510
2511     if (IoIFP(io1))
2512         do_close(gv1, FALSE);
2513     if (IoIFP(io2))
2514         do_close(gv2, FALSE);
2515
2516     TAINT_PROPER("socketpair");
2517     if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0)
2518         RETPUSHUNDEF;
2519     IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE);
2520     IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE);
2521     IoTYPE(io1) = IoTYPE_SOCKET;
2522     IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE);
2523     IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE);
2524     IoTYPE(io2) = IoTYPE_SOCKET;
2525     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2526         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2527         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2528         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2529         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2530         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2531         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2532         RETPUSHUNDEF;
2533     }
2534
2535     RETPUSHYES;
2536 #else
2537     DIE(aTHX_ PL_no_sock_func, "socketpair");
2538 #endif
2539 }
2540
2541 #ifdef HAS_SOCKET
2542
2543 /* also used for: pp_connect() */
2544
2545 PP(pp_bind)
2546 {
2547     dSP;
2548     SV * const addrsv = POPs;
2549     /* OK, so on what platform does bind modify addr?  */
2550     const char *addr;
2551     GV * const gv = MUTABLE_GV(POPs);
2552     IO * const io = GvIOn(gv);
2553     STRLEN len;
2554     int op_type;
2555     int fd;
2556
2557     if (!IoIFP(io))
2558         goto nuts;
2559     fd = PerlIO_fileno(IoIFP(io));
2560     if (fd < 0)
2561         goto nuts;
2562
2563     addr = SvPV_const(addrsv, len);
2564     op_type = PL_op->op_type;
2565     TAINT_PROPER(PL_op_desc[op_type]);
2566     if ((op_type == OP_BIND
2567          ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2568          : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2569         >= 0)
2570         RETPUSHYES;
2571     else
2572         RETPUSHUNDEF;
2573
2574   nuts:
2575     report_evil_fh(gv);
2576     SETERRNO(EBADF,SS_IVCHAN);
2577     RETPUSHUNDEF;
2578 }
2579
2580 PP(pp_listen)
2581 {
2582     dSP;
2583     const int backlog = POPi;
2584     GV * const gv = MUTABLE_GV(POPs);
2585     IO * const io = GvIOn(gv);
2586
2587     if (!IoIFP(io))
2588         goto nuts;
2589
2590     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2591         RETPUSHYES;
2592     else
2593         RETPUSHUNDEF;
2594
2595   nuts:
2596     report_evil_fh(gv);
2597     SETERRNO(EBADF,SS_IVCHAN);
2598     RETPUSHUNDEF;
2599 }
2600
2601 PP(pp_accept)
2602 {
2603     dSP; dTARGET;
2604     IO *nstio;
2605     char namebuf[MAXPATHLEN];
2606 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2607     Sock_size_t len = sizeof (struct sockaddr_in);
2608 #else
2609     Sock_size_t len = sizeof namebuf;
2610 #endif
2611     GV * const ggv = MUTABLE_GV(POPs);
2612     GV * const ngv = MUTABLE_GV(POPs);
2613     int fd;
2614
2615     IO * const gstio = GvIO(ggv);
2616     if (!gstio || !IoIFP(gstio))
2617         goto nuts;
2618
2619     nstio = GvIOn(ngv);
2620     fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2621 #if defined(OEMVS)
2622     if (len == 0) {
2623         /* Some platforms indicate zero length when an AF_UNIX client is
2624          * not bound. Simulate a non-zero-length sockaddr structure in
2625          * this case. */
2626         namebuf[0] = 0;        /* sun_len */
2627         namebuf[1] = AF_UNIX;  /* sun_family */
2628         len = 2;
2629     }
2630 #endif
2631
2632     if (fd < 0)
2633         goto badexit;
2634     if (IoIFP(nstio))
2635         do_close(ngv, FALSE);
2636     IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE);
2637     IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE);
2638     IoTYPE(nstio) = IoTYPE_SOCKET;
2639     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2640         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2641         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2642         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2643         goto badexit;
2644     }
2645
2646 #ifdef __SCO_VERSION__
2647     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2648 #endif
2649
2650     PUSHp(namebuf, len);
2651     RETURN;
2652
2653   nuts:
2654     report_evil_fh(ggv);
2655     SETERRNO(EBADF,SS_IVCHAN);
2656
2657   badexit:
2658     RETPUSHUNDEF;
2659
2660 }
2661
2662 PP(pp_shutdown)
2663 {
2664     dSP; dTARGET;
2665     const int how = POPi;
2666     GV * const gv = MUTABLE_GV(POPs);
2667     IO * const io = GvIOn(gv);
2668
2669     if (!IoIFP(io))
2670         goto nuts;
2671
2672     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2673     RETURN;
2674
2675   nuts:
2676     report_evil_fh(gv);
2677     SETERRNO(EBADF,SS_IVCHAN);
2678     RETPUSHUNDEF;
2679 }
2680
2681
2682 /* also used for: pp_gsockopt() */
2683
2684 PP(pp_ssockopt)
2685 {
2686     dSP;
2687     const int optype = PL_op->op_type;
2688     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2689     const unsigned int optname = (unsigned int) POPi;
2690     const unsigned int lvl = (unsigned int) POPi;
2691     GV * const gv = MUTABLE_GV(POPs);
2692     IO * const io = GvIOn(gv);
2693     int fd;
2694     Sock_size_t len;
2695
2696     if (!IoIFP(io))
2697         goto nuts;
2698
2699     fd = PerlIO_fileno(IoIFP(io));
2700     if (fd < 0)
2701         goto nuts;
2702     switch (optype) {
2703     case OP_GSOCKOPT:
2704         SvGROW(sv, 257);
2705         (void)SvPOK_only(sv);
2706         SvCUR_set(sv,256);
2707         *SvEND(sv) ='\0';
2708         len = SvCUR(sv);
2709         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2710             goto nuts2;
2711 #if defined(_AIX)
2712         /* XXX Configure test: does getsockopt set the length properly? */
2713         if (len == 256)
2714             len = sizeof(int);
2715 #endif
2716         SvCUR_set(sv, len);
2717         *SvEND(sv) ='\0';
2718         PUSHs(sv);
2719         break;
2720     case OP_SSOCKOPT: {
2721             const char *buf;
2722             int aint;
2723             SvGETMAGIC(sv);
2724             if (SvPOKp(sv)) {
2725                 STRLEN l;
2726                 buf = SvPVbyte_nomg(sv, l);
2727                 len = l;
2728             }
2729             else {
2730                 aint = (int)SvIV_nomg(sv);
2731                 buf = (const char *) &aint;
2732                 len = sizeof(int);
2733             }
2734             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2735                 goto nuts2;
2736             PUSHs(&PL_sv_yes);
2737         }
2738         break;
2739     }
2740     RETURN;
2741
2742   nuts:
2743     report_evil_fh(gv);
2744     SETERRNO(EBADF,SS_IVCHAN);
2745   nuts2:
2746     RETPUSHUNDEF;
2747
2748 }
2749
2750
2751 /* also used for: pp_getsockname() */
2752
2753 PP(pp_getpeername)
2754 {
2755     dSP;
2756     const int optype = PL_op->op_type;
2757     GV * const gv = MUTABLE_GV(POPs);
2758     IO * const io = GvIOn(gv);
2759     Sock_size_t len;
2760     SV *sv;
2761     int fd;
2762
2763     if (!IoIFP(io))
2764         goto nuts;
2765
2766 #ifdef HAS_SOCKADDR_STORAGE
2767     len = sizeof(struct sockaddr_storage);
2768 #else
2769     len = 256;
2770 #endif
2771     sv = sv_2mortal(newSV(len+1));
2772     (void)SvPOK_only(sv);
2773     SvCUR_set(sv, len);
2774     *SvEND(sv) ='\0';
2775     fd = PerlIO_fileno(IoIFP(io));
2776     if (fd < 0)
2777         goto nuts;
2778     switch (optype) {
2779     case OP_GETSOCKNAME:
2780         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2781             goto nuts2;
2782         break;
2783     case OP_GETPEERNAME:
2784         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2785             goto nuts2;
2786 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2787         {
2788             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";
2789             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2790             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2791                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2792                         sizeof(u_short) + sizeof(struct in_addr))) {
2793                 goto nuts2;     
2794             }
2795         }
2796 #endif
2797         break;
2798     }
2799 #ifdef BOGUS_GETNAME_RETURN
2800     /* Interactive Unix, getpeername() and getsockname()
2801       does not return valid namelen */
2802     if (len == BOGUS_GETNAME_RETURN)
2803         len = sizeof(struct sockaddr);
2804 #endif
2805     SvCUR_set(sv, len);
2806     *SvEND(sv) ='\0';
2807     PUSHs(sv);
2808     RETURN;
2809
2810   nuts:
2811     report_evil_fh(gv);
2812     SETERRNO(EBADF,SS_IVCHAN);
2813   nuts2:
2814     RETPUSHUNDEF;
2815 }
2816
2817 #endif
2818
2819 /* Stat calls. */
2820
2821 /* also used for: pp_lstat() */
2822
2823 PP(pp_stat)
2824 {
2825     dSP;
2826     GV *gv = NULL;
2827     IO *io = NULL;
2828     U8 gimme;
2829     I32 max = 13;
2830     SV* sv;
2831
2832     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2833                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2834         if (PL_op->op_type == OP_LSTAT) {
2835             if (gv != PL_defgv) {
2836             do_fstat_warning_check:
2837                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2838                                "lstat() on filehandle%s%" SVf,
2839                                 gv ? " " : "",
2840                                 SVfARG(gv
2841                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2842                                         : &PL_sv_no));
2843             } else if (PL_laststype != OP_LSTAT)
2844                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2845                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2846         }
2847
2848         if (gv == PL_defgv) {
2849             if (PL_laststatval < 0)
2850                 SETERRNO(EBADF,RMS_IFI);
2851         } else {
2852           do_fstat_have_io:
2853             PL_laststype = OP_STAT;
2854             PL_statgv = gv ? gv : (GV *)io;
2855             SvPVCLEAR(PL_statname);
2856             if(gv) {
2857                 io = GvIO(gv);
2858             }
2859             if (io) {
2860                     if (IoIFP(io)) {
2861                         int fd = PerlIO_fileno(IoIFP(io));
2862                         if (fd < 0) {
2863                             report_evil_fh(gv);
2864                             PL_laststatval = -1;
2865                             SETERRNO(EBADF,RMS_IFI);
2866                         } else {
2867                             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2868                         }
2869                     } else if (IoDIRP(io)) {
2870                         PL_laststatval =
2871                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2872                     } else {
2873                         report_evil_fh(gv);
2874                         PL_laststatval = -1;
2875                         SETERRNO(EBADF,RMS_IFI);
2876                     }
2877             } else {
2878                 report_evil_fh(gv);
2879                 PL_laststatval = -1;
2880                 SETERRNO(EBADF,RMS_IFI);
2881             }
2882         }
2883
2884         if (PL_laststatval < 0) {
2885             max = 0;
2886         }
2887     }
2888     else {
2889         const char *file;
2890         const char *temp;
2891         STRLEN len;
2892         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
2893             io = MUTABLE_IO(SvRV(sv));
2894             if (PL_op->op_type == OP_LSTAT)
2895                 goto do_fstat_warning_check;
2896             goto do_fstat_have_io; 
2897         }
2898         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2899         temp = SvPV_nomg_const(sv, len);
2900         sv_setpv(PL_statname, temp);
2901         PL_statgv = NULL;
2902         PL_laststype = PL_op->op_type;
2903         file = SvPV_nolen_const(PL_statname);
2904         if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
2905             PL_laststatval = -1;
2906         }
2907         else if (PL_op->op_type == OP_LSTAT)
2908             PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2909         else
2910             PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2911         if (PL_laststatval < 0) {
2912             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2913                 /* PL_warn_nl is constant */
2914                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
2915                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2916                 GCC_DIAG_RESTORE_STMT;
2917             }
2918             max = 0;
2919         }
2920     }
2921
2922     gimme = GIMME_V;
2923     if (gimme != G_LIST) {
2924         if (gimme != G_VOID)
2925             XPUSHs(boolSV(max));
2926         RETURN;
2927     }
2928     if (max) {
2929         EXTEND(SP, max);
2930         EXTEND_MORTAL(max);
2931 #if ST_DEV_SIZE < IVSIZE || (ST_DEV_SIZE == IVSIZE && ST_DEV_SIGN < 0)
2932         mPUSHi(PL_statcache.st_dev);
2933 #elif ST_DEV_SIZE == IVSIZE
2934         mPUSHu(PL_statcache.st_dev);
2935 #else
2936 #  if ST_DEV_SIGN < 0
2937         if (LIKELY((IV)PL_statcache.st_dev == PL_statcache.st_dev)) {
2938             mPUSHi((IV)PL_statcache.st_dev);
2939         }
2940 #  else
2941         if (LIKELY((UV)PL_statcache.st_dev == PL_statcache.st_dev)) {
2942             mPUSHu((UV)PL_statcache.st_dev);
2943         }
2944 #  endif
2945         else {
2946             char buf[sizeof(PL_statcache.st_dev)*3+1];
2947             /* sv_catpvf() casts 'j' size values down to IV, so it
2948                isn't suitable for use here.
2949             */
2950 #    if defined(I_INTTYPES) && defined(HAS_SNPRINTF)
2951 #      if ST_DEV_SIGN < 0
2952             int size = snprintf(buf, sizeof(buf), "%" PRIdMAX, (intmax_t)PL_statcache.st_dev);
2953 #      else
2954             int size = snprintf(buf, sizeof(buf), "%" PRIuMAX, (uintmax_t)PL_statcache.st_dev);
2955 #      endif
2956             STATIC_ASSERT_STMT(sizeof(intmax_t) >= sizeof(PL_statcache.st_dev));
2957             mPUSHp(buf, size);
2958 #    else
2959 #      error extraordinarily large st_dev but no inttypes.h or no snprintf
2960 #    endif
2961         }
2962 #endif
2963         {
2964             /*
2965              * We try to represent st_ino as a native IV or UV where
2966              * possible, but fall back to a decimal string where
2967              * necessary.  The code to generate these decimal strings
2968              * is quite obtuse, because (a) we're portable to non-POSIX
2969              * platforms where st_ino might be signed; (b) we didn't
2970              * necessarily detect at Configure time whether st_ino is
2971              * signed; (c) we're portable to non-POSIX platforms where
2972              * ino_t isn't defined, so have no name for the type of
2973              * st_ino; and (d) sprintf() doesn't necessarily support
2974              * integers as large as st_ino.
2975              */
2976             bool neg;
2977             Stat_t s;
2978             CLANG_DIAG_IGNORE_STMT(-Wtautological-compare);
2979             GCC_DIAG_IGNORE_STMT(-Wtype-limits);
2980             neg = PL_statcache.st_ino < 0;
2981             GCC_DIAG_RESTORE_STMT;
2982             CLANG_DIAG_RESTORE_STMT;
2983             if (neg) {
2984                 s.st_ino = (IV)PL_statcache.st_ino;
2985                 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
2986                     mPUSHi(s.st_ino);
2987                 } else {
2988                     char buf[sizeof(s.st_ino)*3+1], *p;
2989                     s.st_ino = PL_statcache.st_ino;
2990                     for (p = buf + sizeof(buf); p != buf+1; ) {
2991                         Stat_t t;
2992                         t.st_ino = s.st_ino / 10;
2993                         *--p = '0' + (int)(t.st_ino*10 - s.st_ino);
2994                         s.st_ino = t.st_ino;
2995                     }
2996                     while (*p == '0')
2997                         p++;
2998                     *--p = '-';
2999                     mPUSHp(p, buf+sizeof(buf) - p);
3000                 }
3001             } else {
3002                 s.st_ino = (UV)PL_statcache.st_ino;
3003                 if (LIKELY(s.st_ino == PL_statcache.st_ino)) {
3004                     mPUSHu(s.st_ino);
3005                 } else {
3006                     char buf[sizeof(s.st_ino)*3], *p;
3007                     s.st_ino = PL_statcache.st_ino;
3008                     for (p = buf + sizeof(buf); p != buf; ) {
3009                         Stat_t t;
3010                         t.st_ino = s.st_ino / 10;
3011                         *--p = '0' + (int)(s.st_ino - t.st_ino*10);
3012                         s.st_ino = t.st_ino;
3013                     }
3014                     while (*p == '0')
3015                         p++;
3016                     mPUSHp(p, buf+sizeof(buf) - p);
3017                 }
3018             }
3019         }
3020         mPUSHu(PL_statcache.st_mode);
3021         mPUSHu(PL_statcache.st_nlink);
3022         
3023         sv_setuid(PUSHmortal, PL_statcache.st_uid);
3024         sv_setgid(PUSHmortal, PL_statcache.st_gid);
3025
3026 #ifdef USE_STAT_RDEV
3027         mPUSHi(PL_statcache.st_rdev);
3028 #else
3029         PUSHs(newSVpvs_flags("", SVs_TEMP));
3030 #endif
3031 #if Off_t_size > IVSIZE
3032         mPUSHn(PL_statcache.st_size);
3033 #else
3034         mPUSHi(PL_statcache.st_size);
3035 #endif
3036 #ifdef BIG_TIME
3037         mPUSHn(PL_statcache.st_atime);
3038         mPUSHn(PL_statcache.st_mtime);
3039         mPUSHn(PL_statcache.st_ctime);
3040 #else
3041         mPUSHi(PL_statcache.st_atime);
3042         mPUSHi(PL_statcache.st_mtime);
3043         mPUSHi(PL_statcache.st_ctime);
3044 #endif
3045 #ifdef USE_STAT_BLOCKS
3046         mPUSHu(PL_statcache.st_blksize);
3047         mPUSHu(PL_statcache.st_blocks);
3048 #else
3049         PUSHs(newSVpvs_flags("", SVs_TEMP));
3050         PUSHs(newSVpvs_flags("", SVs_TEMP));
3051 #endif
3052     }
3053     RETURN;
3054 }
3055
3056 /* All filetest ops avoid manipulating the perl stack pointer in their main
3057    bodies (since commit d2c4d2d1e22d3125), and return using either
3058    S_ft_return_false() or S_ft_return_true().  These two helper functions are
3059    the only two which manipulate the perl stack.  To ensure that no stack
3060    manipulation macros are used, the filetest ops avoid defining a local copy
3061    of the stack pointer with dSP.  */
3062
3063 /* If the next filetest is stacked up with this one
3064    (PL_op->op_private & OPpFT_STACKING), we leave
3065    the original argument on the stack for success,
3066    and skip the stacked operators on failure.
3067    The next few macros/functions take care of this.
3068 */
3069
3070 static OP *
3071 S_ft_return_false(pTHX_ SV *ret) {
3072     OP *next = NORMAL;
3073     dSP;
3074
3075     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
3076     else                           SETs(ret);
3077     PUTBACK;
3078
3079     if (PL_op->op_private & OPpFT_STACKING) {
3080         while (next && OP_IS_FILETEST(next->op_type)
3081                && next->op_private & OPpFT_STACKED)
3082             next = next->op_next;
3083     }
3084     return next;
3085 }
3086
3087 PERL_STATIC_INLINE OP *
3088 S_ft_return_true(pTHX_ SV *ret) {
3089     dSP;
3090     if (PL_op->op_flags & OPf_REF)
3091         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3092     else if (!(PL_op->op_private & OPpFT_STACKING))
3093         SETs(ret);
3094     PUTBACK;
3095     return NORMAL;
3096 }
3097
3098 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
3099 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
3100 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
3101
3102 #define tryAMAGICftest_MG(chr) STMT_START { \
3103         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3104                 && PL_op->op_flags & OPf_KIDS) {     \
3105             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
3106             if (next) return next;                        \
3107         }                                                  \
3108     } STMT_END
3109
3110 STATIC OP *
3111 S_try_amagic_ftest(pTHX_ char chr) {
3112     SV *const arg = *PL_stack_sp;
3113
3114     assert(chr != '?');
3115     if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg);
3116
3117     if (SvAMAGIC(arg))
3118     {
3119         const char tmpchr = chr;
3120         SV * const tmpsv = amagic_call(arg,
3121                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3122                                 ftest_amg, AMGf_unary);
3123
3124         if (!tmpsv)
3125             return NULL;
3126
3127         return SvTRUE(tmpsv)
3128             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3129     }
3130     return NULL;
3131 }
3132
3133
3134 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3135  *                pp_ftrwrite() */
3136
3137 PP(pp_ftrread)
3138 {
3139     I32 result;
3140     /* Not const, because things tweak this below. Not bool, because there's
3141        no guarantee that OPpFT_ACCESS is <= CHAR_MAX  */
3142 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3143     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3144     /* Giving some sort of initial value silences compilers.  */
3145 #  ifdef R_OK
3146     int access_mode = R_OK;
3147 #  else
3148     int access_mode = 0;
3149 #  endif
3150 #else
3151     /* access_mode is never used, but leaving use_access in makes the
3152        conditional compiling below much clearer.  */
3153     I32 use_access = 0;
3154 #endif
3155     Mode_t stat_mode = S_IRUSR;
3156
3157     bool effective = FALSE;
3158     char opchar = '?';
3159
3160     switch (PL_op->op_type) {
3161     case OP_FTRREAD:    opchar = 'R'; break;
3162     case OP_FTRWRITE:   opchar = 'W'; break;
3163     case OP_FTREXEC:    opchar = 'X'; break;
3164     case OP_FTEREAD:    opchar = 'r'; break;
3165     case OP_FTEWRITE:   opchar = 'w'; break;
3166     case OP_FTEEXEC:    opchar = 'x'; break;
3167     }
3168     tryAMAGICftest_MG(opchar);
3169
3170     switch (PL_op->op_type) {
3171     case OP_FTRREAD:
3172 #if !(defined(HAS_ACCESS) && defined(R_OK))
3173         use_access = 0;
3174 #endif
3175         break;
3176
3177     case OP_FTRWRITE:
3178 #if defined(HAS_ACCESS) && defined(W_OK)
3179         access_mode = W_OK;
3180 #else
3181         use_access = 0;
3182 #endif
3183         stat_mode = S_IWUSR;
3184         break;
3185
3186     case OP_FTREXEC:
3187 #if defined(HAS_ACCESS) && defined(X_OK)
3188         access_mode = X_OK;
3189 #else
3190         use_access = 0;
3191 #endif
3192         stat_mode = S_IXUSR;
3193         break;
3194
3195     case OP_FTEWRITE:
3196 #ifdef PERL_EFF_ACCESS
3197         access_mode = W_OK;
3198 #endif
3199         stat_mode = S_IWUSR;
3200         /* FALLTHROUGH */
3201
3202     case OP_FTEREAD:
3203 #ifndef PERL_EFF_ACCESS
3204         use_access = 0;
3205 #endif
3206         effective = TRUE;
3207         break;
3208
3209     case OP_FTEEXEC:
3210 #ifdef PERL_EFF_ACCESS
3211         access_mode = X_OK;
3212 #else
3213         use_access = 0;
3214 #endif
3215         stat_mode = S_IXUSR;
3216         effective = TRUE;
3217         break;
3218     }
3219
3220     if (use_access) {
3221 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3222         STRLEN len;
3223         const char *name = SvPV(*PL_stack_sp, len);
3224         if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
3225             result = -1;
3226         }
3227         else if (effective) {
3228 #  ifdef PERL_EFF_ACCESS
3229             result = PERL_EFF_ACCESS(name, access_mode);
3230 #  else
3231             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3232                 OP_NAME(PL_op));
3233 #  endif
3234         }
3235         else {
3236 #  ifdef HAS_ACCESS
3237             result = access(name, access_mode);
3238 #  else
3239             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3240 #  endif
3241         }
3242         if (result == 0)
3243             FT_RETURNYES;
3244         if (result < 0)
3245             FT_RETURNUNDEF;
3246         FT_RETURNNO;
3247 #endif
3248     }
3249
3250     result = my_stat_flags(0);
3251     if (result < 0)
3252         FT_RETURNUNDEF;
3253     if (cando(stat_mode, effective, &PL_statcache))
3254         FT_RETURNYES;
3255     FT_RETURNNO;
3256 }
3257
3258
3259 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3260
3261 PP(pp_ftis)
3262 {
3263     I32 result;
3264     const int op_type = PL_op->op_type;
3265     char opchar = '?';
3266
3267     switch (op_type) {
3268     case OP_FTIS:       opchar = 'e'; break;
3269     case OP_FTSIZE:     opchar = 's'; break;
3270     case OP_FTMTIME:    opchar = 'M'; break;
3271     case OP_FTCTIME:    opchar = 'C'; break;
3272     case OP_FTATIME:    opchar = 'A'; break;
3273     }
3274     tryAMAGICftest_MG(opchar);
3275
3276     result = my_stat_flags(0);
3277     if (result < 0)
3278         FT_RETURNUNDEF;
3279     if (op_type == OP_FTIS)
3280         FT_RETURNYES;
3281     {
3282         /* You can't dTARGET inside OP_FTIS, because you'll get
3283            "panic: pad_sv po" - the op is not flagged to have a target.  */
3284         dTARGET;
3285         switch (op_type) {
3286         case OP_FTSIZE:
3287 #if Off_t_size > IVSIZE
3288             sv_setnv(TARG, (NV)PL_statcache.st_size);
3289 #else
3290             sv_setiv(TARG, (IV)PL_statcache.st_size);
3291 #endif
3292             break;
3293         case OP_FTMTIME:
3294             sv_setnv(TARG,
3295                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3296             break;
3297         case OP_FTATIME:
3298             sv_setnv(TARG,
3299                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3300             break;
3301         case OP_FTCTIME:
3302             sv_setnv(TARG,
3303                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3304             break;
3305         }
3306         SvSETMAGIC(TARG);
3307         return SvTRUE_nomg_NN(TARG)
3308             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3309     }
3310 }
3311
3312
3313 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3314  *                pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3315  *                pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3316
3317 PP(pp_ftrowned)
3318 {
3319     I32 result;
3320     char opchar = '?';
3321
3322     switch (PL_op->op_type) {
3323     case OP_FTROWNED:   opchar = 'O'; break;
3324     case OP_FTEOWNED:   opchar = 'o'; break;
3325     case OP_FTZERO:     opchar = 'z'; break;
3326     case OP_FTSOCK:     opchar = 'S'; break;
3327     case OP_FTCHR:      opchar = 'c'; break;
3328     case OP_FTBLK:      opchar = 'b'; break;
3329     case OP_FTFILE:     opchar = 'f'; break;
3330     case OP_FTDIR:      opchar = 'd'; break;
3331     case OP_FTPIPE:     opchar = 'p'; break;
3332     case OP_FTSUID:     opchar = 'u'; break;
3333     case OP_FTSGID:     opchar = 'g'; break;
3334     case OP_FTSVTX:     opchar = 'k'; break;
3335     }
3336     tryAMAGICftest_MG(opchar);
3337
3338     result = my_stat_flags(0);
3339     if (result < 0)
3340         FT_RETURNUNDEF;
3341     switch (PL_op->op_type) {
3342     case OP_FTROWNED:
3343         if (PL_statcache.st_uid == PerlProc_getuid())
3344             FT_RETURNYES;
3345         break;
3346     case OP_FTEOWNED:
3347         if (PL_statcache.st_uid == PerlProc_geteuid())
3348             FT_RETURNYES;
3349         break;
3350     case OP_FTZERO:
3351         if (PL_statcache.st_size == 0)
3352             FT_RETURNYES;
3353         break;
3354     case OP_FTSOCK:
3355         if (S_ISSOCK(PL_statcache.st_mode))
3356             FT_RETURNYES;
3357         break;
3358     case OP_FTCHR:
3359         if (S_ISCHR(PL_statcache.st_mode))
3360             FT_RETURNYES;
3361         break;
3362     case OP_FTBLK:
3363         if (S_ISBLK(PL_statcache.st_mode))
3364             FT_RETURNYES;
3365         break;
3366     case OP_FTFILE:
3367         if (S_ISREG(PL_statcache.st_mode))
3368             FT_RETURNYES;
3369         break;
3370     case OP_FTDIR:
3371         if (S_ISDIR(PL_statcache.st_mode))
3372             FT_RETURNYES;
3373         break;
3374     case OP_FTPIPE:
3375         if (S_ISFIFO(PL_statcache.st_mode))
3376             FT_RETURNYES;
3377         break;
3378 #ifdef S_ISUID
3379     case OP_FTSUID:
3380         if (PL_statcache.st_mode & S_ISUID)
3381             FT_RETURNYES;
3382         break;
3383 #endif
3384 #ifdef S_ISGID
3385     case OP_FTSGID:
3386         if (PL_statcache.st_mode & S_ISGID)
3387             FT_RETURNYES;
3388         break;
3389 #endif
3390 #ifdef S_ISVTX
3391     case OP_FTSVTX:
3392         if (PL_statcache.st_mode & S_ISVTX)
3393             FT_RETURNYES;
3394         break;
3395 #endif
3396     }
3397     FT_RETURNNO;
3398 }
3399
3400 PP(pp_ftlink)
3401 {
3402     I32 result;
3403
3404     tryAMAGICftest_MG('l');
3405     result = my_lstat_flags(0);
3406
3407     if (result < 0)
3408         FT_RETURNUNDEF;
3409     if (S_ISLNK(PL_statcache.st_mode))
3410         FT_RETURNYES;
3411     FT_RETURNNO;
3412 }
3413
3414 PP(pp_fttty)
3415 {
3416     int fd;
3417     GV *gv;
3418     char *name = NULL;
3419     STRLEN namelen;
3420     UV uv;
3421
3422     tryAMAGICftest_MG('t');
3423
3424     if (PL_op->op_flags & OPf_REF)
3425         gv = cGVOP_gv;
3426     else {
3427       SV *tmpsv = *PL_stack_sp;
3428       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3429         name = SvPV_nomg(tmpsv, namelen);
3430         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3431       }
3432     }
3433
3434     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3435         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3436     else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3437         fd = (int)uv;
3438     else
3439         fd = -1;
3440     if (fd < 0) {
3441         SETERRNO(EBADF,RMS_IFI);
3442         FT_RETURNUNDEF;
3443     }
3444     if (PerlLIO_isatty(fd))
3445         FT_RETURNYES;
3446     FT_RETURNNO;
3447 }
3448
3449
3450 /* also used for: pp_ftbinary() */
3451
3452 PP(pp_fttext)
3453 {
3454     I32 i;
3455     SSize_t len;
3456     I32 odd = 0;
3457     STDCHAR tbuf[512];
3458     STDCHAR *s;
3459     IO *io;
3460     SV *sv = NULL;
3461     GV *gv;
3462     PerlIO *fp;
3463     const U8 * first_variant;
3464
3465     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3466
3467     if (PL_op->op_flags & OPf_REF)
3468         gv = cGVOP_gv;
3469     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3470              == OPpFT_STACKED)
3471         gv = PL_defgv;
3472     else {
3473         sv = *PL_stack_sp;
3474         gv = MAYBE_DEREF_GV_nomg(sv);
3475     }
3476
3477     if (gv) {
3478         if (gv == PL_defgv) {
3479             if (PL_statgv)
3480                 io = SvTYPE(PL_statgv) == SVt_PVIO
3481                     ? (IO *)PL_statgv
3482                     : GvIO(PL_statgv);
3483             else {
3484                 goto really_filename;
3485             }
3486         }
3487         else {
3488             PL_statgv = gv;
3489             SvPVCLEAR(PL_statname);
3490             io = GvIO(PL_statgv);
3491         }
3492         PL_laststatval = -1;
3493         PL_laststype = OP_STAT;
3494         if (io && IoIFP(io)) {
3495             int fd;
3496             if (! PerlIO_has_base(IoIFP(io)))
3497                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3498             fd = PerlIO_fileno(IoIFP(io));
3499             if (fd < 0) {
3500                 SETERRNO(EBADF,RMS_IFI);
3501                 FT_RETURNUNDEF;
3502             }
3503             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3504             if (PL_laststatval < 0)
3505                 FT_RETURNUNDEF;
3506             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3507                 if (PL_op->op_type == OP_FTTEXT)
3508                     FT_RETURNNO;
3509                 else
3510                     FT_RETURNYES;
3511             }
3512             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3513                 i = PerlIO_getc(IoIFP(io));
3514                 if (i != EOF)
3515                     (void)PerlIO_ungetc(IoIFP(io),i);
3516                 else
3517                     /* null file is anything */
3518                     FT_RETURNYES;
3519             }
3520             len = PerlIO_get_bufsiz(IoIFP(io));
3521             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3522             /* sfio can have large buffers - limit to 512 */
3523             if (len > 512)
3524                 len = 512;
3525         }
3526         else {
3527             SETERRNO(EBADF,RMS_IFI);
3528             report_evil_fh(gv);
3529             SETERRNO(EBADF,RMS_IFI);
3530             FT_RETURNUNDEF;
3531         }
3532     }
3533     else {
3534         const char *file;
3535         const char *temp;
3536         STRLEN temp_len;
3537         int fd; 
3538
3539         assert(sv);
3540         temp = SvPV_nomg_const(sv, temp_len);
3541         sv_setpv(PL_statname, temp);
3542         if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
3543             PL_laststatval = -1;
3544             PL_laststype = OP_STAT;
3545             FT_RETURNUNDEF;
3546         }
3547       really_filename:
3548         file = SvPVX_const(PL_statname);
3549         PL_statgv = NULL;
3550         if (!(fp = PerlIO_open(file, "r"))) {
3551             if (!gv) {
3552                 PL_laststatval = -1;
3553                 PL_laststype = OP_STAT;
3554             }
3555             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3556                 /* PL_warn_nl is constant */
3557                 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
3558                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3559                 GCC_DIAG_RESTORE_STMT;
3560             }
3561             FT_RETURNUNDEF;
3562         }
3563         PL_laststype = OP_STAT;
3564         fd = PerlIO_fileno(fp);
3565         if (fd < 0) {
3566             (void)PerlIO_close(fp);
3567             SETERRNO(EBADF,RMS_IFI);
3568             FT_RETURNUNDEF;
3569         }
3570         PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3571         if (PL_laststatval < 0) {
3572             dSAVE_ERRNO;
3573             (void)PerlIO_close(fp);
3574             RESTORE_ERRNO;
3575             FT_RETURNUNDEF;
3576         }
3577         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3578         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3579         (void)PerlIO_close(fp);
3580         if (len <= 0) {
3581             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3582                 FT_RETURNNO;            /* special case NFS directories */
3583             FT_RETURNYES;               /* null file is anything */
3584         }
3585         s = tbuf;
3586     }
3587
3588     /* now scan s to look for textiness */
3589
3590 #if defined(DOSISH) || defined(USEMYBINMODE)
3591     /* ignore trailing ^Z on short files */
3592     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3593         --len;
3594 #endif
3595
3596     assert(len);
3597     if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) {
3598
3599         /* Here contains a variant under UTF-8 .  See if the entire string is
3600          * UTF-8. */
3601         if (is_utf8_fixed_width_buf_flags(first_variant,
3602                                           len - ((char *) first_variant - (char *) s),
3603                                           0))
3604         {
3605             if (PL_op->op_type == OP_FTTEXT) {
3606                 FT_RETURNYES;
3607             }
3608             else {
3609                 FT_RETURNNO;
3610             }
3611         }
3612     }
3613
3614     /* Here, is not UTF-8 or is entirely ASCII.  Look through the buffer for
3615      * things that wouldn't be in ASCII text or rich ASCII text.  Count these
3616      * in 'odd' */
3617     for (i = 0; i < len; i++, s++) {
3618         if (!*s) {                      /* null never allowed in text */
3619             odd += len;
3620             break;
3621         }
3622 #ifdef USE_LOCALE_CTYPE
3623         if (IN_LC_RUNTIME(LC_CTYPE)) {
3624             if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3625                 continue;
3626             }
3627         }
3628         else
3629 #endif
3630              if (  isPRINT_A(*s)
3631                     /* VT occurs so rarely in text, that we consider it odd */
3632                  || (isSPACE_A(*s) && *s != VT_NATIVE)
3633
3634                     /* But there is a fair amount of backspaces and escapes in
3635                      * some text */
3636                  || *s == '\b'
3637                  || *s == ESC_NATIVE)
3638         {
3639             continue;
3640         }
3641         odd++;
3642     }
3643
3644     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3645         FT_RETURNNO;
3646     else
3647         FT_RETURNYES;
3648 }
3649
3650 /* File calls. */
3651
3652 PP(pp_chdir)
3653 {
3654     dSP; dTARGET;
3655     const char *tmps = NULL;
3656     GV *gv = NULL;
3657
3658     if( MAXARG == 1 ) {
3659         SV * const sv = POPs;
3660         if (PL_op->op_flags & OPf_SPECIAL) {
3661             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3662             if (!gv) {
3663                 if (ckWARN(WARN_UNOPENED)) {
3664                     Perl_warner(aTHX_ packWARN(WARN_UNOPENED),
3665                                 "chdir() on unopened filehandle %" SVf, sv);
3666                 }
3667                 SETERRNO(EBADF,RMS_IFI);
3668                 PUSHs(&PL_sv_zero);
3669                 TAINT_PROPER("chdir");
3670                 RETURN;
3671             }
3672         }
3673         else if (!(gv = MAYBE_DEREF_GV(sv)))
3674                 tmps = SvPV_nomg_const_nolen(sv);
3675     }
3676     else {
3677         HV * const table = GvHVn(PL_envgv);
3678         SV **svp;
3679
3680         EXTEND(SP, 1);
3681         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3682              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3683 #ifdef VMS
3684              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3685 #endif
3686            )
3687         {
3688             tmps = SvPV_nolen_const(*svp);
3689         }
3690         else {
3691             PUSHs(&PL_sv_zero);
3692             SETERRNO(EINVAL, LIB_INVARG);
3693             TAINT_PROPER("chdir");
3694             RETURN;
3695         }
3696     }
3697
3698     TAINT_PROPER("chdir");
3699     if (gv) {
3700 #ifdef HAS_FCHDIR
3701         IO* const io = GvIO(gv);
3702         if (io) {
3703             if (IoDIRP(io)) {
3704                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3705             } else if (IoIFP(io)) {
3706                 int fd = PerlIO_fileno(IoIFP(io));
3707                 if (fd < 0) {
3708                     goto nuts;
3709                 }
3710                 PUSHi(fchdir(fd) >= 0);
3711             }
3712             else {
3713                 goto nuts;
3714             }
3715         } else {
3716             goto nuts;
3717         }
3718
3719 #else
3720         DIE(aTHX_ PL_no_func, "fchdir");
3721 #endif
3722     }
3723     else 
3724         PUSHi( PerlDir_chdir(tmps) >= 0 );
3725 #ifdef VMS
3726     /* Clear the DEFAULT element of ENV so we'll get the new value
3727      * in the future. */
3728     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3729 #endif
3730     RETURN;
3731
3732 #ifdef HAS_FCHDIR
3733  nuts:
3734     report_evil_fh(gv);
3735     SETERRNO(EBADF,RMS_IFI);
3736     PUSHs(&PL_sv_zero);
3737     RETURN;
3738 #endif
3739 }
3740
3741
3742 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3743
3744 PP(pp_chown)
3745 {
3746     dSP; dMARK; dTARGET;
3747     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3748
3749     SP = MARK;
3750     XPUSHi(value);
3751     RETURN;
3752 }
3753
3754 PP(pp_chroot)
3755 {
3756 #ifdef HAS_CHROOT
3757     dSP; dTARGET;
3758     char * const tmps = POPpx;
3759     TAINT_PROPER("chroot");
3760     PUSHi( chroot(tmps) >= 0 );
3761     RETURN;
3762 #else
3763     DIE(aTHX_ PL_no_func, "chroot");
3764 #endif
3765 }
3766
3767 PP(pp_rename)
3768 {
3769     dSP; dTARGET;
3770     int anum;
3771 #ifndef HAS_RENAME
3772     Stat_t statbuf;
3773 #endif
3774     const char * const tmps2 = POPpconstx;
3775     const char * const tmps = SvPV_nolen_const(TOPs);
3776     TAINT_PROPER("rename");
3777 #ifdef HAS_RENAME
3778     anum = PerlLIO_rename(tmps, tmps2);
3779 #else
3780     if (!(anum = PerlLIO_stat(tmps, &statbuf))) {
3781         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3782             anum = 1;
3783         else {
3784             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
3785                 (void)UNLINK(tmps2);
3786             if (!(anum = link(tmps, tmps2)))
3787                 anum = UNLINK(tmps);
3788         }
3789     }
3790 #endif
3791     SETi( anum >= 0 );
3792     RETURN;
3793 }
3794
3795
3796 /* also used for: pp_symlink() */
3797
3798 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3799 PP(pp_link)
3800 {
3801     dSP; dTARGET;
3802     const int op_type = PL_op->op_type;
3803     int result;
3804
3805 #  ifndef HAS_LINK
3806     if (op_type == OP_LINK)
3807         DIE(aTHX_ PL_no_func, "link");
3808 #  endif
3809 #  ifndef HAS_SYMLINK
3810     if (op_type == OP_SYMLINK)
3811         DIE(aTHX_ PL_no_func, "symlink");
3812 #  endif
3813
3814     {
3815         const char * const tmps2 = POPpconstx;
3816         const char * const tmps = SvPV_nolen_const(TOPs);
3817         TAINT_PROPER(PL_op_desc[op_type]);
3818         result =
3819 #  if defined(HAS_LINK) && defined(HAS_SYMLINK)
3820             /* Both present - need to choose which.  */
3821             (op_type == OP_LINK) ?
3822             PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2);
3823 #  elif defined(HAS_LINK)
3824     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3825         PerlLIO_link(tmps, tmps2);
3826 #  elif defined(HAS_SYMLINK)
3827     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3828         PerlLIO_symlink(tmps, tmps2);
3829 #  endif
3830     }
3831
3832     SETi( result >= 0 );
3833     RETURN;
3834 }
3835 #else
3836
3837 /* also used for: pp_symlink() */
3838
3839 PP(pp_link)
3840 {
3841     /* Have neither.  */
3842     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3843 }
3844 #endif
3845
3846 PP(pp_readlink)
3847 {
3848     dSP;
3849 #ifdef HAS_SYMLINK
3850     dTARGET;
3851     const char *tmps;
3852     char buf[MAXPATHLEN];
3853     SSize_t len;
3854
3855     TAINT;
3856     tmps = POPpconstx;
3857     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3858      * it is impossible to know whether the result was truncated. */
3859     len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1);
3860     if (len < 0)
3861         RETPUSHUNDEF;
3862     buf[len] = '\0';
3863     PUSHp(buf, len);
3864     RETURN;
3865 #else
3866     EXTEND(SP, 1);
3867     RETSETUNDEF;                /* just pretend it's a normal file */
3868 #endif
3869 }
3870
3871 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3872 STATIC int
3873 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3874 {
3875     char * const save_filename = filename;
3876     char *cmdline;
3877     char *s;
3878     PerlIO *myfp;
3879     int anum = 1;
3880     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3881
3882     PERL_ARGS_ASSERT_DOONELINER;
3883
3884     Newx(cmdline, size, char);
3885     my_strlcpy(cmdline, cmd, size);
3886     my_strlcat(cmdline, " ", size);
3887     for (s = cmdline + strlen(cmdline); *filename; ) {
3888         *s++ = '\\';
3889         *s++ = *filename++;
3890     }
3891     if (s - cmdline < size)
3892         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3893     myfp = PerlProc_popen(cmdline, "r");
3894     Safefree(cmdline);
3895
3896     if (myfp) {
3897         SV * const tmpsv = sv_newmortal();
3898         /* Need to save/restore 'PL_rs' ?? */
3899         s = sv_gets(tmpsv, myfp, 0);
3900         (void)PerlProc_pclose(myfp);
3901         if (s != NULL) {
3902             int e;
3903             for (e = 1;
3904 #ifdef HAS_SYS_ERRLIST
3905                  e <= sys_nerr
3906 #endif
3907                  ; e++)
3908             {
3909                 /* you don't see this */
3910                 const char * const errmsg = Strerror(e) ;
3911                 if (!errmsg)
3912                     break;
3913                 if (instr(s, errmsg)) {
3914                     SETERRNO(e,0);
3915                     return 0;
3916                 }
3917             }
3918             SETERRNO(0,0);
3919 #ifndef EACCES
3920 #define EACCES EPERM
3921 #endif
3922             if (instr(s, "cannot make"))
3923                 SETERRNO(EEXIST,RMS_FEX);
3924             else if (instr(s, "existing file"))
3925                 SETERRNO(EEXIST,RMS_FEX);
3926             else if (instr(s, "ile exists"))
3927                 SETERRNO(EEXIST,RMS_FEX);
3928             else if (instr(s, "non-exist"))
3929                 SETERRNO(ENOENT,RMS_FNF);
3930             else if (instr(s, "does not exist"))
3931                 SETERRNO(ENOENT,RMS_FNF);
3932             else if (instr(s, "not empty"))
3933                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3934             else if (instr(s, "cannot access"))
3935                 SETERRNO(EACCES,RMS_PRV);
3936             else
3937                 SETERRNO(EPERM,RMS_PRV);
3938             return 0;
3939         }
3940         else {  /* some mkdirs return no failure indication */
3941             Stat_t statbuf;
3942             anum = (PerlLIO_stat(save_filename, &statbuf) >= 0);
3943             if (PL_op->op_type == OP_RMDIR)
3944                 anum = !anum;
3945             if (anum)
3946                 SETERRNO(0,0);
3947             else
3948                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3949         }
3950         return anum;
3951     }
3952     else
3953         return 0;
3954 }
3955 #endif
3956
3957 /* This macro removes trailing slashes from a directory name.
3958  * Different operating and file systems take differently to
3959  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3960  * any number of trailing slashes should be allowed.
3961  * Thusly we snip them away so that even non-conforming
3962  * systems are happy.
3963  * We should probably do this "filtering" for all
3964  * the functions that expect (potentially) directory names:
3965  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3966  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3967
3968 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3969     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3970         do { \
3971             (len)--; \
3972         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3973         (tmps) = savepvn((tmps), (len)); \
3974         (copy) = TRUE; \
3975     }
3976
3977 PP(pp_mkdir)
3978 {
3979     dSP; dTARGET;
3980     STRLEN len;
3981     const char *tmps;
3982     bool copy = FALSE;
3983     const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777;
3984
3985     TRIMSLASHES(tmps,len,copy);
3986
3987     TAINT_PROPER("mkdir");
3988 #ifdef HAS_MKDIR
3989     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3990 #else
3991     {
3992     int oldumask;
3993     SETi( dooneliner("mkdir", tmps) );
3994     oldumask = PerlLIO_umask(0);
3995     PerlLIO_umask(oldumask);
3996     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3997     }
3998 #endif
3999     if (copy)
4000         Safefree(tmps);
4001     RETURN;
4002 }
4003
4004 PP(pp_rmdir)
4005 {
4006     dSP; dTARGET;
4007     STRLEN len;
4008     const char *tmps;
4009     bool copy = FALSE;
4010
4011     TRIMSLASHES(tmps,len,copy);
4012     TAINT_PROPER("rmdir");
4013 #ifdef HAS_RMDIR
4014     SETi( PerlDir_rmdir(tmps) >= 0 );
4015 #else
4016     SETi( dooneliner("rmdir", tmps) );
4017 #endif
4018     if (copy)
4019         Safefree(tmps);
4020     RETURN;
4021 }
4022
4023 /* Directory calls. */
4024
4025 PP(pp_open_dir)
4026 {
4027 #if defined(Direntry_t) && defined(HAS_READDIR)
4028     dSP;
4029     const char * const dirname = POPpconstx;
4030     GV * const gv = MUTABLE_GV(POPs);
4031     IO * const io = GvIOn(gv);
4032
4033     if ((IoIFP(io) || IoOFP(io)))
4034         Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle",
4035                          HEKfARG(GvENAME_HEK(gv)));
4036     if (IoDIRP(io))
4037         PerlDir_close(IoDIRP(io));
4038     if (!(IoDIRP(io) = PerlDir_open(dirname)))
4039         goto nope;
4040
4041     RETPUSHYES;
4042   nope:
4043     if (!errno)
4044         SETERRNO(EBADF,RMS_DIR);
4045     RETPUSHUNDEF;
4046 #else
4047     DIE(aTHX_ PL_no_dir_func, "opendir");
4048 #endif
4049 }
4050
4051 PP(pp_readdir)
4052 {
4053 #if !defined(Direntry_t) || !defined(HAS_READDIR)
4054     DIE(aTHX_ PL_no_dir_func, "readdir");
4055 #else
4056 #if !defined(I_DIRENT) && !defined(VMS)
4057     Direntry_t *readdir (DIR *);
4058 #endif
4059     dSP;
4060
4061     SV *sv;
4062     const U8 gimme = GIMME_V;
4063     GV * const gv = MUTABLE_GV(POPs);
4064     const Direntry_t *dp;
4065     IO * const io = GvIOn(gv);
4066
4067     if (!IoDIRP(io)) {
4068         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4069                        "readdir() attempted on invalid dirhandle %" HEKf,
4070                             HEKfARG(GvENAME_HEK(gv)));
4071         goto nope;
4072     }
4073
4074     do {
4075         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
4076         if (!dp)
4077             break;
4078 #ifdef DIRNAMLEN
4079         sv = newSVpvn(dp->d_name, dp->d_namlen);
4080 #else
4081         sv = newSVpv(dp->d_name, 0);
4082 #endif
4083         if (!(IoFLAGS(io) & IOf_UNTAINT))
4084             SvTAINTED_on(sv);
4085         mXPUSHs(sv);
4086     } while (gimme == G_LIST);
4087
4088     if (!dp && gimme != G_LIST)
4089         RETPUSHUNDEF;
4090
4091     RETURN;
4092
4093   nope:
4094     if (!errno)
4095         SETERRNO(EBADF,RMS_ISI);
4096     if (gimme == G_LIST)
4097         RETURN;
4098     else
4099         RETPUSHUNDEF;
4100 #endif
4101 }
4102
4103 PP(pp_telldir)
4104 {
4105 #if defined(HAS_TELLDIR) || defined(telldir)
4106     dSP; dTARGET;
4107  /* XXX does _anyone_ need this? --AD 2/20/1998 */
4108  /* XXX netbsd still seemed to.
4109     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4110     --JHI 1999-Feb-02 */
4111 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4112     long telldir (DIR *);
4113 # endif
4114     GV * const gv = MUTABLE_GV(POPs);
4115     IO * const io = GvIOn(gv);
4116
4117     if (!IoDIRP(io)) {
4118         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4119                        "telldir() attempted on invalid dirhandle %" HEKf,
4120                             HEKfARG(GvENAME_HEK(gv)));
4121         goto nope;
4122     }
4123
4124     PUSHi( PerlDir_tell(IoDIRP(io)) );
4125     RETURN;
4126   nope:
4127     if (!errno)
4128         SETERRNO(EBADF,RMS_ISI);
4129     RETPUSHUNDEF;
4130 #else
4131     DIE(aTHX_ PL_no_dir_func, "telldir");
4132 #endif
4133 }
4134
4135 PP(pp_seekdir)
4136 {
4137 #if defined(HAS_SEEKDIR) || defined(seekdir)
4138     dSP;
4139     const long along = POPl;
4140     GV * const gv = MUTABLE_GV(POPs);
4141     IO * const io = GvIOn(gv);
4142
4143     if (!IoDIRP(io)) {
4144         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4145                        "seekdir() attempted on invalid dirhandle %" HEKf,
4146                                 HEKfARG(GvENAME_HEK(gv)));
4147         goto nope;
4148     }
4149     (void)PerlDir_seek(IoDIRP(io), along);
4150
4151     RETPUSHYES;
4152   nope:
4153     if (!errno)
4154         SETERRNO(EBADF,RMS_ISI);
4155     RETPUSHUNDEF;
4156 #else
4157     DIE(aTHX_ PL_no_dir_func, "seekdir");
4158 #endif
4159 }
4160
4161 PP(pp_rewinddir)
4162 {
4163 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4164     dSP;
4165     GV * const gv = MUTABLE_GV(POPs);
4166     IO * const io = GvIOn(gv);
4167
4168     if (!IoDIRP(io)) {
4169         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4170                        "rewinddir() attempted on invalid dirhandle %" HEKf,
4171                                 HEKfARG(GvENAME_HEK(gv)));
4172         goto nope;
4173     }
4174     (void)PerlDir_rewind(IoDIRP(io));
4175     RETPUSHYES;
4176   nope:
4177     if (!errno)
4178         SETERRNO(EBADF,RMS_ISI);
4179     RETPUSHUNDEF;
4180 #else
4181     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4182 #endif
4183 }
4184
4185 PP(pp_closedir)
4186 {
4187 #if defined(Direntry_t) && defined(HAS_READDIR)
4188     dSP;
4189     GV * const gv = MUTABLE_GV(POPs);
4190     IO * const io = GvIOn(gv);
4191
4192     if (!IoDIRP(io)) {
4193         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4194                        "closedir() attempted on invalid dirhandle %" HEKf,
4195                                 HEKfARG(GvENAME_HEK(gv)));
4196         goto nope;
4197     }
4198 #ifdef VOID_CLOSEDIR
4199     PerlDir_close(IoDIRP(io));
4200 #else
4201     if (PerlDir_close(IoDIRP(io)) < 0) {
4202         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4203         goto nope;
4204     }
4205 #endif
4206     IoDIRP(io) = 0;
4207
4208     RETPUSHYES;
4209   nope:
4210     if (!errno)
4211         SETERRNO(EBADF,RMS_IFI);
4212     RETPUSHUNDEF;
4213 #else
4214     DIE(aTHX_ PL_no_dir_func, "closedir");
4215 #endif
4216 }
4217
4218 /* Process control. */
4219
4220 PP(pp_fork)
4221 {
4222 #ifdef HAS_FORK
4223     dSP; dTARGET;
4224     Pid_t childpid;
4225 #ifdef HAS_SIGPROCMASK
4226     sigset_t oldmask, newmask;
4227 #endif
4228
4229     EXTEND(SP, 1);
4230     PERL_FLUSHALL_FOR_CHILD;
4231 #ifdef HAS_SIGPROCMASK
4232     sigfillset(&newmask);
4233     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4234 #endif
4235     childpid = PerlProc_fork();
4236     if (childpid == 0) {
4237         int sig;
4238         PL_sig_pending = 0;
4239         if (PL_psig_pend)
4240             for (sig = 1; sig < SIG_SIZE; sig++)
4241                 PL_psig_pend[sig] = 0;
4242     }
4243 #ifdef HAS_SIGPROCMASK
4244     {
4245         dSAVE_ERRNO;
4246         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4247         RESTORE_ERRNO;
4248     }
4249 #endif
4250     if (childpid < 0)
4251         RETPUSHUNDEF;
4252     if (!childpid) {
4253 #ifdef PERL_USES_PL_PIDSTATUS
4254         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4255 #endif
4256     }
4257     PUSHi(childpid);
4258     RETURN;
4259 #elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__)
4260     dSP; dTARGET;
4261     Pid_t childpid;
4262
4263     EXTEND(SP, 1);
4264     PERL_FLUSHALL_FOR_CHILD;
4265     childpid = PerlProc_fork();
4266     if (childpid == -1)
4267         RETPUSHUNDEF;
4268     PUSHi(childpid);
4269     RETURN;
4270 #else
4271     DIE(aTHX_ PL_no_func, "fork");
4272 #endif
4273 }
4274
4275 PP(pp_wait)
4276 {
4277 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4278     dSP; dTARGET;
4279     Pid_t childpid;
4280     int argflags;
4281
4282     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4283         childpid = wait4pid(-1, &argflags, 0);
4284     else {
4285         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4286                errno == EINTR) {
4287           PERL_ASYNC_CHECK();
4288         }
4289     }
4290 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4291     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4292     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4293 #  else
4294     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4295 #  endif
4296     XPUSHi(childpid);
4297     RETURN;
4298 #else
4299     DIE(aTHX_ PL_no_func, "wait");
4300 #endif
4301 }
4302
4303 PP(pp_waitpid)
4304 {
4305 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4306     dSP; dTARGET;
4307     const int optype = POPi;
4308     const Pid_t pid = TOPi;
4309     Pid_t result;
4310 #ifdef __amigaos4__
4311     int argflags = 0;
4312     result = amigaos_waitpid(aTHX_ optype, pid, &argflags);
4313     STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1);
4314     result = result == 0 ? pid : -1;
4315 #else
4316     int argflags;
4317
4318     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4319         result = wait4pid(pid, &argflags, optype);
4320     else {
4321         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4322                errno == EINTR) {
4323           PERL_ASYNC_CHECK();
4324         }
4325     }
4326 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4327     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4328     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4329 #  else
4330     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4331 #  endif
4332 # endif /* __amigaos4__ */
4333     SETi(result);
4334     RETURN;
4335 #else
4336     DIE(aTHX_ PL_no_func, "waitpid");
4337 #endif
4338 }
4339
4340 PP(pp_system)
4341 {
4342     dSP; dMARK; dORIGMARK; dTARGET;
4343 #if defined(__LIBCATAMOUNT__)
4344     PL_statusvalue = -1;
4345     SP = ORIGMARK;
4346     XPUSHi(-1);
4347 #else
4348     I32 value;
4349 # ifdef __amigaos4__
4350     void * result;
4351 # else
4352     int result;
4353 # endif
4354
4355     while (++MARK <= SP) {
4356         SV *origsv = *MARK, *copysv;
4357         STRLEN len;
4358         char *pv;
4359         SvGETMAGIC(origsv);
4360 #if defined(WIN32) || defined(__VMS)
4361         /*
4362          * Because of a nasty platform-specific variation on the meaning
4363          * of arguments to this op, we must preserve numeric arguments
4364          * as numeric, not just retain the string value.
4365          */
4366         if (SvNIOK(origsv) || SvNIOKp(origsv)) {
4367             copysv = newSV_type(SVt_PVNV);
4368             sv_2mortal(copysv);
4369             if (SvPOK(origsv) || SvPOKp(origsv)) {
4370                 pv = SvPV_nomg(origsv, len);
4371                 sv_setpvn(copysv, pv, len);
4372                 SvPOK_off(copysv);
4373             }
4374             if (SvIOK(origsv) || SvIOKp(origsv))
4375                 SvIV_set(copysv, SvIVX(origsv));
4376             if (SvNOK(origsv) || SvNOKp(origsv))
4377                 SvNV_set(copysv, SvNVX(origsv));
4378             SvFLAGS(copysv) |= SvFLAGS(origsv) &
4379                 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK|
4380                     SVf_UTF8|SVf_IVisUV);
4381         } else
4382 #endif
4383         {
4384             pv = SvPV_nomg(origsv, len);
4385             copysv = newSVpvn_flags(pv, len,
4386                         (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP);
4387         }
4388         *MARK = copysv;
4389     }
4390     MARK = ORIGMARK;
4391
4392     if (TAINTING_get) {
4393         TAINT_ENV();
4394         TAINT_PROPER("system");
4395     }
4396     PERL_FLUSHALL_FOR_CHILD;
4397 #if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4398     {
4399 #ifdef __amigaos4__
4400         struct UserData userdata;
4401         pthread_t proc;
4402 #else
4403         Pid_t childpid;
4404 #endif
4405         int pp[2];
4406         I32 did_pipes = 0;
4407         bool child_success = FALSE;
4408 #ifdef HAS_SIGPROCMASK
4409         sigset_t newset, oldset;
4410 #endif
4411
4412         if (PerlProc_pipe_cloexec(pp) >= 0)
4413             did_pipes = 1;
4414 #ifdef __amigaos4__
4415         amigaos_fork_set_userdata(aTHX_
4416                                   &userdata,
4417                                   did_pipes,
4418                                   pp[1],
4419                                   SP,
4420                                   mark);
4421         pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata);
4422         child_success = proc > 0;
4423 #else
4424 #ifdef HAS_SIGPROCMASK
4425         sigemptyset(&newset);
4426         sigaddset(&newset, SIGCHLD);
4427         sigprocmask(SIG_BLOCK, &newset, &oldset);
4428 #endif
4429         while ((childpid = PerlProc_fork()) == -1) {
4430             if (errno != EAGAIN) {
4431                 value = -1;
4432                 SP = ORIGMARK;
4433                 XPUSHi(value);
4434                 if (did_pipes) {
4435                     PerlLIO_close(pp[0]);
4436                     PerlLIO_close(pp[1]);
4437                 }
4438 #ifdef HAS_SIGPROCMASK
4439                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4440 #endif
4441                 RETURN;
4442             }
4443             sleep(5);
4444         }
4445         child_success = childpid > 0;
4446 #endif
4447         if (child_success) {
4448             Sigsave_t ihand,qhand; /* place to save signals during system() */
4449             int status;
4450
4451 #ifndef __amigaos4__
4452             if (did_pipes)
4453                 PerlLIO_close(pp[1]);
4454 #endif
4455 #ifndef PERL_MICRO
4456             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4457             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4458 #endif
4459 #ifdef __amigaos4__
4460             result = pthread_join(proc, (void **)&status);
4461 #else
4462             do {
4463                 result = wait4pid(childpid, &status, 0);
4464             } while (result == -1 && errno == EINTR);
4465 #endif
4466 #ifndef PERL_MICRO
4467 #ifdef HAS_SIGPROCMASK
4468             sigprocmask(SIG_SETMASK, &oldset, NULL);
4469 #endif
4470             (void)rsignal_restore(SIGINT, &ihand);
4471             (void)rsignal_restore(SIGQUIT, &qhand);
4472 #endif
4473             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4474             SP = ORIGMARK;
4475             if (did_pipes) {
4476                 int errkid;
4477                 unsigned n = 0;
4478
4479                 while (n < sizeof(int)) {
4480                     const SSize_t n1 = PerlLIO_read(pp[0],
4481                                       (void*)(((char*)&errkid)+n),
4482                                       (sizeof(int)) - n);
4483                     if (n1 <= 0)
4484                         break;
4485                     n += n1;
4486                 }
4487                 PerlLIO_close(pp[0]);
4488                 if (n) {                        /* Error */
4489                     if (n != sizeof(int))
4490                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4491                     errno = errkid;             /* Propagate errno from kid */
4492 #ifdef __amigaos4__
4493                     /* The pipe always has something in it
4494                      * so n alone is not enough. */
4495                     if (errno > 0)
4496 #endif
4497                     {
4498                         STATUS_NATIVE_CHILD_SET(-1);
4499                     }
4500                 }
4501             }
4502             XPUSHi(STATUS_CURRENT);
4503             RETURN;
4504         }
4505 #ifndef __amigaos4__
4506 #ifdef HAS_SIGPROCMASK
4507         sigprocmask(SIG_SETMASK, &oldset, NULL);
4508 #endif
4509         if (did_pipes)
4510             PerlLIO_close(pp[0]);
4511         if (PL_op->op_flags & OPf_STACKED) {
4512             SV * const really = *++MARK;
4513             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4514         }
4515         else if (SP - MARK != 1)
4516             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4517         else {
4518             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4519         }
4520 #endif /* __amigaos4__ */
4521         PerlProc__exit(-1);
4522     }
4523 #else /* ! FORK or VMS or OS/2 */
4524     PL_statusvalue = 0;
4525     result = 0;
4526     if (PL_op->op_flags & OPf_STACKED) {
4527         SV * const really = *++MARK;
4528 #  if defined(WIN32) || defined(OS2) || defined(__VMS)
4529         value = (I32)do_aspawn(really, MARK, SP);
4530 #  else
4531         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4532 #  endif
4533     }
4534     else if (SP - MARK != 1) {
4535 #  if defined(WIN32) || defined(OS2) || defined(__VMS)
4536         value = (I32)do_aspawn(NULL, MARK, SP);
4537 #  else
4538         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4539 #  endif
4540     }
4541     else {
4542         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4543     }
4544     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4545         result = 1;
4546     STATUS_NATIVE_CHILD_SET(value);
4547     SP = ORIGMARK;
4548     XPUSHi(result ? value : STATUS_CURRENT);
4549 #endif /* !FORK or VMS or OS/2 */
4550 #endif
4551     RETURN;
4552 }
4553
4554 PP(pp_exec)
4555 {
4556     dSP; dMARK; dORIGMARK; dTARGET;
4557     I32 value;
4558
4559     if (TAINTING_get) {
4560         TAINT_ENV();
4561         while (++MARK <= SP) {
4562             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4563             if (TAINT_get)
4564                 break;
4565         }
4566         MARK = ORIGMARK;
4567         TAINT_PROPER("exec");
4568     }
4569
4570     PERL_FLUSHALL_FOR_CHILD;
4571     if (PL_op->op_flags & OPf_STACKED) {
4572         SV * const really = *++MARK;
4573         value = (I32)do_aexec(really, MARK, SP);
4574     }
4575     else if (SP - MARK != 1)
4576 #ifdef VMS
4577         value = (I32)vms_do_aexec(NULL, MARK, SP);
4578 #else
4579         value = (I32)do_aexec(NULL, MARK, SP);
4580 #endif
4581     else {
4582 #ifdef VMS
4583         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4584 #else
4585         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4586 #endif
4587     }
4588     SP = ORIGMARK;
4589     XPUSHi(value);
4590     RETURN;
4591 }
4592
4593 PP(pp_getppid)
4594 {
4595 #ifdef HAS_GETPPID
4596     dSP; dTARGET;
4597     XPUSHi( getppid() );
4598     RETURN;
4599 #else
4600     DIE(aTHX_ PL_no_func, "getppid");
4601 #endif
4602 }
4603
4604 PP(pp_getpgrp)
4605 {
4606 #ifdef HAS_GETPGRP
4607     dSP; dTARGET;
4608     Pid_t pgrp;
4609     const Pid_t pid =
4610         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4611
4612 #ifdef BSD_GETPGRP
4613     pgrp = (I32)BSD_GETPGRP(pid);
4614 #else
4615     if (pid != 0 && pid != PerlProc_getpid())
4616         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4617     pgrp = getpgrp();
4618 #endif
4619     XPUSHi(pgrp);
4620     RETURN;
4621 #else
4622     DIE(aTHX_ PL_no_func, "getpgrp");
4623 #endif
4624 }
4625
4626 PP(pp_setpgrp)
4627 {
4628 #ifdef HAS_SETPGRP
4629     dSP; dTARGET;
4630     Pid_t pgrp;
4631     Pid_t pid;
4632     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4633     if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4634     else {
4635         pid = 0;
4636         EXTEND(SP,1);
4637         SP++;
4638     }
4639
4640     TAINT_PROPER("setpgrp");
4641 #ifdef BSD_SETPGRP
4642     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4643 #else
4644     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4645         || (pid != 0 && pid != PerlProc_getpid()))
4646     {
4647         DIE(aTHX_ "setpgrp can't take arguments");
4648     }
4649     SETi( setpgrp() >= 0 );
4650 #endif /* USE_BSDPGRP */
4651     RETURN;
4652 #else
4653     DIE(aTHX_ PL_no_func, "setpgrp");
4654 #endif
4655 }
4656
4657 /*
4658  * The glibc headers typedef __priority_which_t to an enum under C, but
4659  * under C++, it keeps it as int. -Wc++-compat doesn't know this, so we
4660  * need to explicitly cast it to shut up the warning.
4661  */
4662 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4663 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4664 #else
4665 #  define PRIORITY_WHICH_T(which) which
4666 #endif
4667
4668 PP(pp_getpriority)
4669 {
4670 #ifdef HAS_GETPRIORITY
4671     dSP; dTARGET;
4672     const int who = POPi;
4673     const int which = TOPi;
4674     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4675     RETURN;
4676 #else
4677     DIE(aTHX_ PL_no_func, "getpriority");
4678 #endif
4679 }
4680
4681 PP(pp_setpriority)
4682 {
4683 #ifdef HAS_SETPRIORITY
4684     dSP; dTARGET;
4685     const int niceval = POPi;
4686     const int who = POPi;
4687     const int which = TOPi;
4688     TAINT_PROPER("setpriority");
4689     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4690     RETURN;
4691 #else
4692     DIE(aTHX_ PL_no_func, "setpriority");
4693 #endif
4694 }
4695
4696 #undef PRIORITY_WHICH_T
4697
4698 /* Time calls. */
4699
4700 PP(pp_time)
4701 {
4702     dSP; dTARGET;
4703 #ifdef BIG_TIME
4704     XPUSHn( (NV)time(NULL) );
4705 #else
4706     XPUSHu( (UV)time(NULL) );
4707 #endif
4708     RETURN;
4709 }
4710
4711 PP(pp_tms)
4712 {
4713 #ifdef HAS_TIMES
4714     dSP;
4715     struct tms timesbuf;
4716
4717     EXTEND(SP, 4);
4718     (void)PerlProc_times(&timesbuf);
4719
4720     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4721     if (GIMME_V == G_LIST) {
4722         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4723         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4724         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4725     }
4726     RETURN;
4727 #elif defined(PERL_MICRO)
4728     dSP;
4729     mPUSHn(0.0);
4730     EXTEND(SP, 4);
4731     if (GIMME_V == G_LIST) {
4732          mPUSHn(0.0);
4733          mPUSHn(0.0);
4734          mPUSHn(0.0);
4735     }
4736     RETURN;
4737 #else
4738     DIE(aTHX_ "times not implemented");
4739 #endif /* HAS_TIMES */
4740 }
4741
4742 /* The 32 bit int year limits the times we can represent to these
4743    boundaries with a few days wiggle room to account for time zone
4744    offsets
4745 */
4746 /* Sat Jan  3 00:00:00 -2147481748 */
4747 #define TIME_LOWER_BOUND -67768100567755200.0
4748 /* Sun Dec 29 12:00:00  2147483647 */
4749 #define TIME_UPPER_BOUND  67767976233316800.0
4750
4751
4752 /* also used for: pp_localtime() */
4753
4754 PP(pp_gmtime)
4755 {
4756     dSP;
4757     Time64_T when;
4758     struct TM tmbuf;
4759     struct TM *err;
4760     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4761     static const char * const dayname[] =
4762         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4763     static const char * const monname[] =
4764         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4765          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4766
4767     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4768         time_t now;
4769         (void)time(&now);
4770         when = (Time64_T)now;
4771     }
4772     else {
4773         NV input = Perl_floor(POPn);
4774         const bool pl_isnan = Perl_isnan(input);
4775         when = (Time64_T)input;
4776         if (UNLIKELY(pl_isnan || when != input)) {
4777             /* diag_listed_as: gmtime(%f) too large */
4778             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4779                            "%s(%.0" NVff ") too large", opname, input);
4780             if (pl_isnan) {
4781                 err = NULL;
4782                 goto failed;
4783             }
4784         }
4785     }
4786
4787     if ( TIME_LOWER_BOUND > when ) {
4788         /* diag_listed_as: gmtime(%f) too small */
4789         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4790                        "%s(%.0" NVff ") too small", opname, when);
4791         err = NULL;
4792     }
4793     else if( when > TIME_UPPER_BOUND ) {
4794         /* diag_listed_as: gmtime(%f) too small */
4795         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4796                        "%s(%.0" NVff ") too large", opname, when);
4797         err = NULL;
4798     }
4799     else {
4800         if (PL_op->op_type == OP_LOCALTIME)
4801             err = Perl_localtime64_r(&when, &tmbuf);
4802         else
4803             err = Perl_gmtime64_r(&when, &tmbuf);
4804     }
4805
4806     if (err == NULL) {
4807         /* diag_listed_as: gmtime(%f) failed */
4808         /* XXX %lld broken for quads */
4809       failed:
4810         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4811                        "%s(%.0" NVff ") failed", opname, when);
4812     }
4813
4814     if (GIMME_V != G_LIST) {    /* scalar context */
4815         EXTEND(SP, 1);
4816         if (err == NULL)
4817             RETPUSHUNDEF;
4818        else {
4819            dTARGET;
4820            PUSHs(TARG);
4821            Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf,
4822                                 dayname[tmbuf.tm_wday],
4823                                 monname[tmbuf.tm_mon],
4824                                 tmbuf.tm_mday,
4825                                 tmbuf.tm_hour,
4826                                 tmbuf.tm_min,
4827                                 tmbuf.tm_sec,
4828                                 (IV)tmbuf.tm_year + 1900);
4829         }
4830     }
4831     else {                      /* list context */
4832         if ( err == NULL )
4833             RETURN;
4834
4835         EXTEND(SP, 9);
4836         EXTEND_MORTAL(9);
4837         mPUSHi(tmbuf.tm_sec);
4838         mPUSHi(tmbuf.tm_min);
4839         mPUSHi(tmbuf.tm_hour);
4840         mPUSHi(tmbuf.tm_mday);
4841         mPUSHi(tmbuf.tm_mon);
4842         mPUSHn(tmbuf.tm_year);
4843         mPUSHi(tmbuf.tm_wday);
4844         mPUSHi(tmbuf.tm_yday);
4845         mPUSHi(tmbuf.tm_isdst);
4846     }
4847     RETURN;
4848 }
4849
4850 PP(pp_alarm)
4851 {
4852 #ifdef HAS_ALARM
4853     dSP; dTARGET;
4854     /* alarm() takes an unsigned int number of seconds, and return the
4855      * unsigned int number of seconds remaining in the previous alarm
4856      * (alarms don't stack).  Therefore negative return values are not
4857      * possible. */
4858     int anum = POPi;
4859     if (anum < 0) {
4860         /* Note that while the C library function alarm() as such has
4861          * no errors defined (or in other words, properly behaving client
4862          * code shouldn't expect any), alarm() being obsoleted by
4863          * setitimer() and often being implemented in terms of
4864          * setitimer(), can fail. */
4865         /* diag_listed_as: %s() with negative argument */
4866         Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4867                          "alarm() with negative argument");
4868         SETERRNO(EINVAL, LIB_INVARG);
4869         RETPUSHUNDEF;
4870     }
4871     else {
4872         unsigned int retval = alarm(anum);
4873         if ((int)retval < 0) /* Strictly speaking "cannot happen". */
4874             RETPUSHUNDEF;
4875         PUSHu(retval);
4876         RETURN;
4877     }
4878 #else
4879     DIE(aTHX_ PL_no_func, "alarm");
4880 #endif
4881 }
4882
4883 PP(pp_sleep)
4884 {
4885     dSP; dTARGET;
4886     Time_t lasttime;
4887     Time_t when;
4888
4889     (void)time(&lasttime);
4890     if (MAXARG < 1 || (!TOPs && !POPs))
4891         PerlProc_pause();
4892     else {
4893         const I32 duration = POPi;
4894         if (duration < 0) {
4895           /* diag_listed_as: %s() with negative argument */
4896           Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC),
4897                            "sleep() with negative argument");
4898           SETERRNO(EINVAL, LIB_INVARG);
4899           XPUSHs(&PL_sv_zero);
4900           RETURN;
4901         } else {
4902           PerlProc_sleep((unsigned int)duration);
4903         }
4904     }
4905     (void)time(&when);
4906     XPUSHu((UV)(when - lasttime));
4907     RETURN;
4908 }
4909
4910 /* Shared memory. */
4911 /* Merged with some message passing. */
4912
4913 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4914
4915 PP(pp_shmwrite)
4916 {
4917 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4918     dSP; dMARK; dTARGET;
4919     const int op_type = PL_op->op_type;
4920     I32 value;
4921
4922     switch (op_type) {
4923     case OP_MSGSND:
4924         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4925         break;
4926     case OP_MSGRCV:
4927         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4928         break;
4929     case OP_SEMOP:
4930         value = (I32)(do_semop(MARK, SP) >= 0);
4931         break;
4932     default:
4933         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4934         break;
4935     }
4936
4937     SP = MARK;
4938     PUSHi(value);
4939     RETURN;
4940 #else
4941     return Perl_pp_semget(aTHX);
4942 #endif
4943 }
4944
4945 /* Semaphores. */
4946
4947 /* also used for: pp_msgget() pp_shmget() */
4948
4949 PP(pp_semget)
4950 {
4951 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4952     dSP; dMARK; dTARGET;
4953     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4954     SP = MARK;
4955     if (anum == -1)
4956         RETPUSHUNDEF;
4957     PUSHi(anum);
4958     RETURN;
4959 #else
4960     DIE(aTHX_ "System V IPC is not implemented on this machine");
4961 #endif
4962 }