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