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