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