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