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