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