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