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