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