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