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