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