This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
08aead72d8b57555852153d75798607df6a7b022
[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 = GvIOn(gv);
2375     int fd;
2376
2377     if (IoIFP(io))
2378         do_close(gv, FALSE);
2379
2380     TAINT_PROPER("socket");
2381     fd = PerlSock_socket(domain, type, protocol);
2382     if (fd < 0)
2383         RETPUSHUNDEF;
2384     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2385     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2386     IoTYPE(io) = IoTYPE_SOCKET;
2387     if (!IoIFP(io) || !IoOFP(io)) {
2388         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2389         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2390         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2391         RETPUSHUNDEF;
2392     }
2393 #if defined(HAS_FCNTL) && defined(F_SETFD)
2394     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2395 #endif
2396
2397     RETPUSHYES;
2398 }
2399 #endif
2400
2401 PP(pp_sockpair)
2402 {
2403 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2404     dVAR; dSP;
2405     int fd[2];
2406     const int protocol = POPi;
2407     const int type = POPi;
2408     const int domain = POPi;
2409
2410     GV * const gv2 = MUTABLE_GV(POPs);
2411     IO * const io2 = GvIOn(gv2);
2412     GV * const gv1 = MUTABLE_GV(POPs);
2413     IO * const io1 = GvIOn(gv1);
2414
2415     if (IoIFP(io1))
2416         do_close(gv1, FALSE);
2417     if (IoIFP(io2))
2418         do_close(gv2, FALSE);
2419
2420     TAINT_PROPER("socketpair");
2421     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2422         RETPUSHUNDEF;
2423     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2424     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2425     IoTYPE(io1) = IoTYPE_SOCKET;
2426     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2427     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2428     IoTYPE(io2) = IoTYPE_SOCKET;
2429     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2430         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2431         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2432         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2433         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2434         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2435         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2436         RETPUSHUNDEF;
2437     }
2438 #if defined(HAS_FCNTL) && defined(F_SETFD)
2439     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2440     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2441 #endif
2442
2443     RETPUSHYES;
2444 #else
2445     DIE(aTHX_ PL_no_sock_func, "socketpair");
2446 #endif
2447 }
2448
2449 #ifdef HAS_SOCKET
2450
2451 PP(pp_bind)
2452 {
2453     dVAR; dSP;
2454     SV * const addrsv = POPs;
2455     /* OK, so on what platform does bind modify addr?  */
2456     const char *addr;
2457     GV * const gv = MUTABLE_GV(POPs);
2458     IO * const io = GvIOn(gv);
2459     STRLEN len;
2460     int op_type;
2461
2462     if (!IoIFP(io))
2463         goto nuts;
2464
2465     addr = SvPV_const(addrsv, len);
2466     op_type = PL_op->op_type;
2467     TAINT_PROPER(PL_op_desc[op_type]);
2468     if ((op_type == OP_BIND
2469          ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2470          : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2471         >= 0)
2472         RETPUSHYES;
2473     else
2474         RETPUSHUNDEF;
2475
2476 nuts:
2477     report_evil_fh(gv);
2478     SETERRNO(EBADF,SS_IVCHAN);
2479     RETPUSHUNDEF;
2480 }
2481
2482 PP(pp_listen)
2483 {
2484     dVAR; dSP;
2485     const int backlog = POPi;
2486     GV * const gv = MUTABLE_GV(POPs);
2487     IO * const io = GvIOn(gv);
2488
2489     if (!IoIFP(io))
2490         goto nuts;
2491
2492     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2493         RETPUSHYES;
2494     else
2495         RETPUSHUNDEF;
2496
2497 nuts:
2498     report_evil_fh(gv);
2499     SETERRNO(EBADF,SS_IVCHAN);
2500     RETPUSHUNDEF;
2501 }
2502
2503 PP(pp_accept)
2504 {
2505     dVAR; dSP; dTARGET;
2506     IO *nstio;
2507     char namebuf[MAXPATHLEN];
2508 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2509     Sock_size_t len = sizeof (struct sockaddr_in);
2510 #else
2511     Sock_size_t len = sizeof namebuf;
2512 #endif
2513     GV * const ggv = MUTABLE_GV(POPs);
2514     GV * const ngv = MUTABLE_GV(POPs);
2515     int fd;
2516
2517     IO * const gstio = GvIO(ggv);
2518     if (!gstio || !IoIFP(gstio))
2519         goto nuts;
2520
2521     nstio = GvIOn(ngv);
2522     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2523 #if defined(OEMVS)
2524     if (len == 0) {
2525         /* Some platforms indicate zero length when an AF_UNIX client is
2526          * not bound. Simulate a non-zero-length sockaddr structure in
2527          * this case. */
2528         namebuf[0] = 0;        /* sun_len */
2529         namebuf[1] = AF_UNIX;  /* sun_family */
2530         len = 2;
2531     }
2532 #endif
2533
2534     if (fd < 0)
2535         goto badexit;
2536     if (IoIFP(nstio))
2537         do_close(ngv, FALSE);
2538     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2539     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2540     IoTYPE(nstio) = IoTYPE_SOCKET;
2541     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2542         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2543         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2544         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2545         goto badexit;
2546     }
2547 #if defined(HAS_FCNTL) && defined(F_SETFD)
2548     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2549 #endif
2550
2551 #ifdef __SCO_VERSION__
2552     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2553 #endif
2554
2555     PUSHp(namebuf, len);
2556     RETURN;
2557
2558 nuts:
2559     report_evil_fh(ggv);
2560     SETERRNO(EBADF,SS_IVCHAN);
2561
2562 badexit:
2563     RETPUSHUNDEF;
2564
2565 }
2566
2567 PP(pp_shutdown)
2568 {
2569     dVAR; dSP; dTARGET;
2570     const int how = POPi;
2571     GV * const gv = MUTABLE_GV(POPs);
2572     IO * const io = GvIOn(gv);
2573
2574     if (!IoIFP(io))
2575         goto nuts;
2576
2577     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2578     RETURN;
2579
2580 nuts:
2581     report_evil_fh(gv);
2582     SETERRNO(EBADF,SS_IVCHAN);
2583     RETPUSHUNDEF;
2584 }
2585
2586 PP(pp_ssockopt)
2587 {
2588     dVAR; dSP;
2589     const int optype = PL_op->op_type;
2590     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2591     const unsigned int optname = (unsigned int) POPi;
2592     const unsigned int lvl = (unsigned int) POPi;
2593     GV * const gv = MUTABLE_GV(POPs);
2594     IO * const io = GvIOn(gv);
2595     int fd;
2596     Sock_size_t len;
2597
2598     if (!io || !IoIFP(io))
2599         goto nuts;
2600
2601     fd = PerlIO_fileno(IoIFP(io));
2602     switch (optype) {
2603     case OP_GSOCKOPT:
2604         SvGROW(sv, 257);
2605         (void)SvPOK_only(sv);
2606         SvCUR_set(sv,256);
2607         *SvEND(sv) ='\0';
2608         len = SvCUR(sv);
2609         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2610             goto nuts2;
2611         SvCUR_set(sv, len);
2612         *SvEND(sv) ='\0';
2613         PUSHs(sv);
2614         break;
2615     case OP_SSOCKOPT: {
2616 #if defined(__SYMBIAN32__)
2617 # define SETSOCKOPT_OPTION_VALUE_T void *
2618 #else
2619 # define SETSOCKOPT_OPTION_VALUE_T const char *
2620 #endif
2621         /* XXX TODO: We need to have a proper type (a Configure probe,
2622          * etc.) for what the C headers think of the third argument of
2623          * setsockopt(), the option_value read-only buffer: is it
2624          * a "char *", or a "void *", const or not.  Some compilers
2625          * don't take kindly to e.g. assuming that "char *" implicitly
2626          * promotes to a "void *", or to explicitly promoting/demoting
2627          * consts to non/vice versa.  The "const void *" is the SUS
2628          * definition, but that does not fly everywhere for the above
2629          * reasons. */
2630             SETSOCKOPT_OPTION_VALUE_T buf;
2631             int aint;
2632             if (SvPOKp(sv)) {
2633                 STRLEN l;
2634                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2635                 len = l;
2636             }
2637             else {
2638                 aint = (int)SvIV(sv);
2639                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2640                 len = sizeof(int);
2641             }
2642             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2643                 goto nuts2;
2644             PUSHs(&PL_sv_yes);
2645         }
2646         break;
2647     }
2648     RETURN;
2649
2650 nuts:
2651     report_evil_fh(gv);
2652     SETERRNO(EBADF,SS_IVCHAN);
2653 nuts2:
2654     RETPUSHUNDEF;
2655
2656 }
2657
2658 PP(pp_getpeername)
2659 {
2660     dVAR; dSP;
2661     const int optype = PL_op->op_type;
2662     GV * const gv = MUTABLE_GV(POPs);
2663     IO * const io = GvIOn(gv);
2664     Sock_size_t len;
2665     SV *sv;
2666     int fd;
2667
2668     if (!io || !IoIFP(io))
2669         goto nuts;
2670
2671     sv = sv_2mortal(newSV(257));
2672     (void)SvPOK_only(sv);
2673     len = 256;
2674     SvCUR_set(sv, len);
2675     *SvEND(sv) ='\0';
2676     fd = PerlIO_fileno(IoIFP(io));
2677     switch (optype) {
2678     case OP_GETSOCKNAME:
2679         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2680             goto nuts2;
2681         break;
2682     case OP_GETPEERNAME:
2683         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2684             goto nuts2;
2685 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2686         {
2687             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";
2688             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2689             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2690                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2691                         sizeof(u_short) + sizeof(struct in_addr))) {
2692                 goto nuts2;     
2693             }
2694         }
2695 #endif
2696         break;
2697     }
2698 #ifdef BOGUS_GETNAME_RETURN
2699     /* Interactive Unix, getpeername() and getsockname()
2700       does not return valid namelen */
2701     if (len == BOGUS_GETNAME_RETURN)
2702         len = sizeof(struct sockaddr);
2703 #endif
2704     SvCUR_set(sv, len);
2705     *SvEND(sv) ='\0';
2706     PUSHs(sv);
2707     RETURN;
2708
2709 nuts:
2710     report_evil_fh(gv);
2711     SETERRNO(EBADF,SS_IVCHAN);
2712 nuts2:
2713     RETPUSHUNDEF;
2714 }
2715
2716 #endif
2717
2718 /* Stat calls. */
2719
2720 PP(pp_stat)
2721 {
2722     dVAR;
2723     dSP;
2724     GV *gv = NULL;
2725     IO *io = NULL;
2726     I32 gimme;
2727     I32 max = 13;
2728     SV* sv;
2729
2730     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2731                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2732         if (PL_op->op_type == OP_LSTAT) {
2733             if (gv != PL_defgv) {
2734             do_fstat_warning_check:
2735                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2736                                "lstat() on filehandle%s%"SVf,
2737                                 gv ? " " : "",
2738                                 SVfARG(gv
2739                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2740                                         : &PL_sv_no));
2741             } else if (PL_laststype != OP_LSTAT)
2742                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2743                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2744         }
2745
2746         if (gv != PL_defgv) {
2747             bool havefp;
2748           do_fstat_have_io:
2749             havefp = FALSE;
2750             PL_laststype = OP_STAT;
2751             PL_statgv = gv ? gv : (GV *)io;
2752             sv_setpvs(PL_statname, "");
2753             if(gv) {
2754                 io = GvIO(gv);
2755             }
2756             if (io) {
2757                     if (IoIFP(io)) {
2758                         PL_laststatval = 
2759                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
2760                         havefp = TRUE;
2761                     } else if (IoDIRP(io)) {
2762                         PL_laststatval =
2763                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2764                         havefp = TRUE;
2765                     } else {
2766                         PL_laststatval = -1;
2767                     }
2768             }
2769             else PL_laststatval = -1;
2770             if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2771         }
2772
2773         if (PL_laststatval < 0) {
2774             max = 0;
2775         }
2776     }
2777     else {
2778         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
2779             io = MUTABLE_IO(SvRV(sv));
2780             if (PL_op->op_type == OP_LSTAT)
2781                 goto do_fstat_warning_check;
2782             goto do_fstat_have_io; 
2783         }
2784         
2785         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2786         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2787         PL_statgv = NULL;
2788         PL_laststype = PL_op->op_type;
2789         if (PL_op->op_type == OP_LSTAT)
2790             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2791         else
2792             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2793         if (PL_laststatval < 0) {
2794             if (ckWARN(WARN_NEWLINE) &&
2795                     strchr(SvPV_nolen_const(PL_statname), '\n'))
2796             {
2797                 /* PL_warn_nl is constant */
2798                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2799                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2800                 GCC_DIAG_RESTORE;
2801             }
2802             max = 0;
2803         }
2804     }
2805
2806     gimme = GIMME_V;
2807     if (gimme != G_ARRAY) {
2808         if (gimme != G_VOID)
2809             XPUSHs(boolSV(max));
2810         RETURN;
2811     }
2812     if (max) {
2813         EXTEND(SP, max);
2814         EXTEND_MORTAL(max);
2815         mPUSHi(PL_statcache.st_dev);
2816 #if ST_INO_SIZE > IVSIZE
2817         mPUSHn(PL_statcache.st_ino);
2818 #else
2819 #   if ST_INO_SIGN <= 0
2820         mPUSHi(PL_statcache.st_ino);
2821 #   else
2822         mPUSHu(PL_statcache.st_ino);
2823 #   endif
2824 #endif
2825         mPUSHu(PL_statcache.st_mode);
2826         mPUSHu(PL_statcache.st_nlink);
2827         
2828         sv_setuid(PUSHmortal, PL_statcache.st_uid);
2829         sv_setgid(PUSHmortal, PL_statcache.st_gid);
2830
2831 #ifdef USE_STAT_RDEV
2832         mPUSHi(PL_statcache.st_rdev);
2833 #else
2834         PUSHs(newSVpvs_flags("", SVs_TEMP));
2835 #endif
2836 #if Off_t_size > IVSIZE
2837         mPUSHn(PL_statcache.st_size);
2838 #else
2839         mPUSHi(PL_statcache.st_size);
2840 #endif
2841 #ifdef BIG_TIME
2842         mPUSHn(PL_statcache.st_atime);
2843         mPUSHn(PL_statcache.st_mtime);
2844         mPUSHn(PL_statcache.st_ctime);
2845 #else
2846         mPUSHi(PL_statcache.st_atime);
2847         mPUSHi(PL_statcache.st_mtime);
2848         mPUSHi(PL_statcache.st_ctime);
2849 #endif
2850 #ifdef USE_STAT_BLOCKS
2851         mPUSHu(PL_statcache.st_blksize);
2852         mPUSHu(PL_statcache.st_blocks);
2853 #else
2854         PUSHs(newSVpvs_flags("", SVs_TEMP));
2855         PUSHs(newSVpvs_flags("", SVs_TEMP));
2856 #endif
2857     }
2858     RETURN;
2859 }
2860
2861 /* All filetest ops avoid manipulating the perl stack pointer in their main
2862    bodies (since commit d2c4d2d1e22d3125), and return using either
2863    S_ft_return_false() or S_ft_return_true().  These two helper functions are
2864    the only two which manipulate the perl stack.  To ensure that no stack
2865    manipulation macros are used, the filetest ops avoid defining a local copy
2866    of the stack pointer with dSP.  */
2867
2868 /* If the next filetest is stacked up with this one
2869    (PL_op->op_private & OPpFT_STACKING), we leave
2870    the original argument on the stack for success,
2871    and skip the stacked operators on failure.
2872    The next few macros/functions take care of this.
2873 */
2874
2875 static OP *
2876 S_ft_return_false(pTHX_ SV *ret) {
2877     OP *next = NORMAL;
2878     dSP;
2879
2880     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2881     else                           SETs(ret);
2882     PUTBACK;
2883
2884     if (PL_op->op_private & OPpFT_STACKING) {
2885         while (OP_IS_FILETEST(next->op_type)
2886                && next->op_private & OPpFT_STACKED)
2887             next = next->op_next;
2888     }
2889     return next;
2890 }
2891
2892 PERL_STATIC_INLINE OP *
2893 S_ft_return_true(pTHX_ SV *ret) {
2894     dSP;
2895     if (PL_op->op_flags & OPf_REF)
2896         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
2897     else if (!(PL_op->op_private & OPpFT_STACKING))
2898         SETs(ret);
2899     PUTBACK;
2900     return NORMAL;
2901 }
2902
2903 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
2904 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
2905 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
2906
2907 #define tryAMAGICftest_MG(chr) STMT_START { \
2908         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2909                 && PL_op->op_flags & OPf_KIDS) {     \
2910             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
2911             if (next) return next;                        \
2912         }                                                  \
2913     } STMT_END
2914
2915 STATIC OP *
2916 S_try_amagic_ftest(pTHX_ char chr) {
2917     dVAR;
2918     SV *const arg = *PL_stack_sp;
2919
2920     assert(chr != '?');
2921     if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
2922
2923     if (SvAMAGIC(arg))
2924     {
2925         const char tmpchr = chr;
2926         SV * const tmpsv = amagic_call(arg,
2927                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2928                                 ftest_amg, AMGf_unary);
2929
2930         if (!tmpsv)
2931             return NULL;
2932
2933         return SvTRUE(tmpsv)
2934             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
2935     }
2936     return NULL;
2937 }
2938
2939
2940 PP(pp_ftrread)
2941 {
2942     dVAR;
2943     I32 result;
2944     /* Not const, because things tweak this below. Not bool, because there's
2945        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2946 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2947     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2948     /* Giving some sort of initial value silences compilers.  */
2949 #  ifdef R_OK
2950     int access_mode = R_OK;
2951 #  else
2952     int access_mode = 0;
2953 #  endif
2954 #else
2955     /* access_mode is never used, but leaving use_access in makes the
2956        conditional compiling below much clearer.  */
2957     I32 use_access = 0;
2958 #endif
2959     Mode_t stat_mode = S_IRUSR;
2960
2961     bool effective = FALSE;
2962     char opchar = '?';
2963
2964     switch (PL_op->op_type) {
2965     case OP_FTRREAD:    opchar = 'R'; break;
2966     case OP_FTRWRITE:   opchar = 'W'; break;
2967     case OP_FTREXEC:    opchar = 'X'; break;
2968     case OP_FTEREAD:    opchar = 'r'; break;
2969     case OP_FTEWRITE:   opchar = 'w'; break;
2970     case OP_FTEEXEC:    opchar = 'x'; break;
2971     }
2972     tryAMAGICftest_MG(opchar);
2973
2974     switch (PL_op->op_type) {
2975     case OP_FTRREAD:
2976 #if !(defined(HAS_ACCESS) && defined(R_OK))
2977         use_access = 0;
2978 #endif
2979         break;
2980
2981     case OP_FTRWRITE:
2982 #if defined(HAS_ACCESS) && defined(W_OK)
2983         access_mode = W_OK;
2984 #else
2985         use_access = 0;
2986 #endif
2987         stat_mode = S_IWUSR;
2988         break;
2989
2990     case OP_FTREXEC:
2991 #if defined(HAS_ACCESS) && defined(X_OK)
2992         access_mode = X_OK;
2993 #else
2994         use_access = 0;
2995 #endif
2996         stat_mode = S_IXUSR;
2997         break;
2998
2999     case OP_FTEWRITE:
3000 #ifdef PERL_EFF_ACCESS
3001         access_mode = W_OK;
3002 #endif
3003         stat_mode = S_IWUSR;
3004         /* fall through */
3005
3006     case OP_FTEREAD:
3007 #ifndef PERL_EFF_ACCESS
3008         use_access = 0;
3009 #endif
3010         effective = TRUE;
3011         break;
3012
3013     case OP_FTEEXEC:
3014 #ifdef PERL_EFF_ACCESS
3015         access_mode = X_OK;
3016 #else
3017         use_access = 0;
3018 #endif
3019         stat_mode = S_IXUSR;
3020         effective = TRUE;
3021         break;
3022     }
3023
3024     if (use_access) {
3025 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3026         const char *name = SvPV_nolen(*PL_stack_sp);
3027         if (effective) {
3028 #  ifdef PERL_EFF_ACCESS
3029             result = PERL_EFF_ACCESS(name, access_mode);
3030 #  else
3031             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3032                 OP_NAME(PL_op));
3033 #  endif
3034         }
3035         else {
3036 #  ifdef HAS_ACCESS
3037             result = access(name, access_mode);
3038 #  else
3039             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3040 #  endif
3041         }
3042         if (result == 0)
3043             FT_RETURNYES;
3044         if (result < 0)
3045             FT_RETURNUNDEF;
3046         FT_RETURNNO;
3047 #endif
3048     }
3049
3050     result = my_stat_flags(0);
3051     if (result < 0)
3052         FT_RETURNUNDEF;
3053     if (cando(stat_mode, effective, &PL_statcache))
3054         FT_RETURNYES;
3055     FT_RETURNNO;
3056 }
3057
3058 PP(pp_ftis)
3059 {
3060     dVAR;
3061     I32 result;
3062     const int op_type = PL_op->op_type;
3063     char opchar = '?';
3064
3065     switch (op_type) {
3066     case OP_FTIS:       opchar = 'e'; break;
3067     case OP_FTSIZE:     opchar = 's'; break;
3068     case OP_FTMTIME:    opchar = 'M'; break;
3069     case OP_FTCTIME:    opchar = 'C'; break;
3070     case OP_FTATIME:    opchar = 'A'; break;
3071     }
3072     tryAMAGICftest_MG(opchar);
3073
3074     result = my_stat_flags(0);
3075     if (result < 0)
3076         FT_RETURNUNDEF;
3077     if (op_type == OP_FTIS)
3078         FT_RETURNYES;
3079     {
3080         /* You can't dTARGET inside OP_FTIS, because you'll get
3081            "panic: pad_sv po" - the op is not flagged to have a target.  */
3082         dTARGET;
3083         switch (op_type) {
3084         case OP_FTSIZE:
3085 #if Off_t_size > IVSIZE
3086             sv_setnv(TARG, (NV)PL_statcache.st_size);
3087 #else
3088             sv_setiv(TARG, (IV)PL_statcache.st_size);
3089 #endif
3090             break;
3091         case OP_FTMTIME:
3092             sv_setnv(TARG,
3093                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3094             break;
3095         case OP_FTATIME:
3096             sv_setnv(TARG,
3097                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3098             break;
3099         case OP_FTCTIME:
3100             sv_setnv(TARG,
3101                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3102             break;
3103         }
3104         SvSETMAGIC(TARG);
3105         return SvTRUE_nomg(TARG)
3106             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3107     }
3108 }
3109
3110 PP(pp_ftrowned)
3111 {
3112     dVAR;
3113     I32 result;
3114     char opchar = '?';
3115
3116     switch (PL_op->op_type) {
3117     case OP_FTROWNED:   opchar = 'O'; break;
3118     case OP_FTEOWNED:   opchar = 'o'; break;
3119     case OP_FTZERO:     opchar = 'z'; break;
3120     case OP_FTSOCK:     opchar = 'S'; break;
3121     case OP_FTCHR:      opchar = 'c'; break;
3122     case OP_FTBLK:      opchar = 'b'; break;
3123     case OP_FTFILE:     opchar = 'f'; break;
3124     case OP_FTDIR:      opchar = 'd'; break;
3125     case OP_FTPIPE:     opchar = 'p'; break;
3126     case OP_FTSUID:     opchar = 'u'; break;
3127     case OP_FTSGID:     opchar = 'g'; break;
3128     case OP_FTSVTX:     opchar = 'k'; break;
3129     }
3130     tryAMAGICftest_MG(opchar);
3131
3132     /* I believe that all these three are likely to be defined on most every
3133        system these days.  */
3134 #ifndef S_ISUID
3135     if(PL_op->op_type == OP_FTSUID) {
3136         FT_RETURNNO;
3137     }
3138 #endif
3139 #ifndef S_ISGID
3140     if(PL_op->op_type == OP_FTSGID) {
3141         FT_RETURNNO;
3142     }
3143 #endif
3144 #ifndef S_ISVTX
3145     if(PL_op->op_type == OP_FTSVTX) {
3146         FT_RETURNNO;
3147     }
3148 #endif
3149
3150     result = my_stat_flags(0);
3151     if (result < 0)
3152         FT_RETURNUNDEF;
3153     switch (PL_op->op_type) {
3154     case OP_FTROWNED:
3155         if (PL_statcache.st_uid == PerlProc_getuid())
3156             FT_RETURNYES;
3157         break;
3158     case OP_FTEOWNED:
3159         if (PL_statcache.st_uid == PerlProc_geteuid())
3160             FT_RETURNYES;
3161         break;
3162     case OP_FTZERO:
3163         if (PL_statcache.st_size == 0)
3164             FT_RETURNYES;
3165         break;
3166     case OP_FTSOCK:
3167         if (S_ISSOCK(PL_statcache.st_mode))
3168             FT_RETURNYES;
3169         break;
3170     case OP_FTCHR:
3171         if (S_ISCHR(PL_statcache.st_mode))
3172             FT_RETURNYES;
3173         break;
3174     case OP_FTBLK:
3175         if (S_ISBLK(PL_statcache.st_mode))
3176             FT_RETURNYES;
3177         break;
3178     case OP_FTFILE:
3179         if (S_ISREG(PL_statcache.st_mode))
3180             FT_RETURNYES;
3181         break;
3182     case OP_FTDIR:
3183         if (S_ISDIR(PL_statcache.st_mode))
3184             FT_RETURNYES;
3185         break;
3186     case OP_FTPIPE:
3187         if (S_ISFIFO(PL_statcache.st_mode))
3188             FT_RETURNYES;
3189         break;
3190 #ifdef S_ISUID
3191     case OP_FTSUID:
3192         if (PL_statcache.st_mode & S_ISUID)
3193             FT_RETURNYES;
3194         break;
3195 #endif
3196 #ifdef S_ISGID
3197     case OP_FTSGID:
3198         if (PL_statcache.st_mode & S_ISGID)
3199             FT_RETURNYES;
3200         break;
3201 #endif
3202 #ifdef S_ISVTX
3203     case OP_FTSVTX:
3204         if (PL_statcache.st_mode & S_ISVTX)
3205             FT_RETURNYES;
3206         break;
3207 #endif
3208     }
3209     FT_RETURNNO;
3210 }
3211
3212 PP(pp_ftlink)
3213 {
3214     dVAR;
3215     I32 result;
3216
3217     tryAMAGICftest_MG('l');
3218     result = my_lstat_flags(0);
3219
3220     if (result < 0)
3221         FT_RETURNUNDEF;
3222     if (S_ISLNK(PL_statcache.st_mode))
3223         FT_RETURNYES;
3224     FT_RETURNNO;
3225 }
3226
3227 PP(pp_fttty)
3228 {
3229     dVAR;
3230     int fd;
3231     GV *gv;
3232     char *name = NULL;
3233     STRLEN namelen;
3234
3235     tryAMAGICftest_MG('t');
3236
3237     if (PL_op->op_flags & OPf_REF)
3238         gv = cGVOP_gv;
3239     else {
3240       SV *tmpsv = *PL_stack_sp;
3241       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3242         name = SvPV_nomg(tmpsv, namelen);
3243         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3244       }
3245     }
3246
3247     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3248         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3249     else if (name && isDIGIT(*name))
3250             fd = atoi(name);
3251     else
3252         FT_RETURNUNDEF;
3253     if (PerlLIO_isatty(fd))
3254         FT_RETURNYES;
3255     FT_RETURNNO;
3256 }
3257
3258 PP(pp_fttext)
3259 {
3260     dVAR;
3261     I32 i;
3262     SSize_t len;
3263     I32 odd = 0;
3264     STDCHAR tbuf[512];
3265     STDCHAR *s;
3266     IO *io;
3267     SV *sv = NULL;
3268     GV *gv;
3269     PerlIO *fp;
3270
3271     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3272
3273     if (PL_op->op_flags & OPf_REF)
3274         gv = cGVOP_gv;
3275     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3276              == OPpFT_STACKED)
3277         gv = PL_defgv;
3278     else {
3279         sv = *PL_stack_sp;
3280         gv = MAYBE_DEREF_GV_nomg(sv);
3281     }
3282
3283     if (gv) {
3284         if (gv == PL_defgv) {
3285             if (PL_statgv)
3286                 io = SvTYPE(PL_statgv) == SVt_PVIO
3287                     ? (IO *)PL_statgv
3288                     : GvIO(PL_statgv);
3289             else {
3290                 goto really_filename;
3291             }
3292         }
3293         else {
3294             PL_statgv = gv;
3295             sv_setpvs(PL_statname, "");
3296             io = GvIO(PL_statgv);
3297         }
3298         PL_laststatval = -1;
3299         PL_laststype = OP_STAT;
3300         if (io && IoIFP(io)) {
3301             if (! PerlIO_has_base(IoIFP(io)))
3302                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3303             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3304             if (PL_laststatval < 0)
3305                 FT_RETURNUNDEF;
3306             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3307                 if (PL_op->op_type == OP_FTTEXT)
3308                     FT_RETURNNO;
3309                 else
3310                     FT_RETURNYES;
3311             }
3312             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3313                 i = PerlIO_getc(IoIFP(io));
3314                 if (i != EOF)
3315                     (void)PerlIO_ungetc(IoIFP(io),i);
3316             }
3317             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3318                 FT_RETURNYES;
3319             len = PerlIO_get_bufsiz(IoIFP(io));
3320             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3321             /* sfio can have large buffers - limit to 512 */
3322             if (len > 512)
3323                 len = 512;
3324         }
3325         else {
3326             SETERRNO(EBADF,RMS_IFI);
3327             report_evil_fh(gv);
3328             SETERRNO(EBADF,RMS_IFI);
3329             FT_RETURNUNDEF;
3330         }
3331     }
3332     else {
3333         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3334       really_filename:
3335         PL_statgv = NULL;
3336         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3337             if (!gv) {
3338                 PL_laststatval = -1;
3339                 PL_laststype = OP_STAT;
3340             }
3341             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3342                                                '\n'))
3343             {
3344                 /* PL_warn_nl is constant */
3345                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3346                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3347                 GCC_DIAG_RESTORE;
3348             }
3349             FT_RETURNUNDEF;
3350         }
3351         PL_laststype = OP_STAT;
3352         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3353         if (PL_laststatval < 0) {
3354             (void)PerlIO_close(fp);
3355             FT_RETURNUNDEF;
3356         }
3357         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3358         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3359         (void)PerlIO_close(fp);
3360         if (len <= 0) {
3361             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3362                 FT_RETURNNO;            /* special case NFS directories */
3363             FT_RETURNYES;               /* null file is anything */
3364         }
3365         s = tbuf;
3366     }
3367
3368     /* now scan s to look for textiness */
3369     /*   XXX ASCII dependent code */
3370
3371 #if defined(DOSISH) || defined(USEMYBINMODE)
3372     /* ignore trailing ^Z on short files */
3373     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3374         --len;
3375 #endif
3376
3377     for (i = 0; i < len; i++, s++) {
3378         if (!*s) {                      /* null never allowed in text */
3379             odd += len;
3380             break;
3381         }
3382 #ifdef EBCDIC
3383         else if (!(isPRINT(*s) || isSPACE(*s)))
3384             odd++;
3385 #else
3386         else if (*s & 128) {
3387 #ifdef USE_LOCALE
3388             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3389                 continue;
3390 #endif
3391             /* utf8 characters don't count as odd */
3392             if (UTF8_IS_START(*s)) {
3393                 int ulen = UTF8SKIP(s);
3394                 if (ulen < len - i) {
3395                     int j;
3396                     for (j = 1; j < ulen; j++) {
3397                         if (!UTF8_IS_CONTINUATION(s[j]))
3398                             goto not_utf8;
3399                     }
3400                     --ulen;     /* loop does extra increment */
3401                     s += ulen;
3402                     i += ulen;
3403                     continue;
3404                 }
3405             }
3406           not_utf8:
3407             odd++;
3408         }
3409         else if (*s < 32 &&
3410           *s != '\n' && *s != '\r' && *s != '\b' &&
3411           *s != '\t' && *s != '\f' && *s != 27)
3412             odd++;
3413 #endif
3414     }
3415
3416     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3417         FT_RETURNNO;
3418     else
3419         FT_RETURNYES;
3420 }
3421
3422 /* File calls. */
3423
3424 PP(pp_chdir)
3425 {
3426     dVAR; dSP; dTARGET;
3427     const char *tmps = NULL;
3428     GV *gv = NULL;
3429
3430     if( MAXARG == 1 ) {
3431         SV * const sv = POPs;
3432         if (PL_op->op_flags & OPf_SPECIAL) {
3433             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3434         }
3435         else if (!(gv = MAYBE_DEREF_GV(sv)))
3436                 tmps = SvPV_nomg_const_nolen(sv);
3437     }
3438
3439     if( !gv && (!tmps || !*tmps) ) {
3440         HV * const table = GvHVn(PL_envgv);
3441         SV **svp;
3442
3443         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3444              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3445 #ifdef VMS
3446              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3447 #endif
3448            )
3449         {
3450             if( MAXARG == 1 )
3451                 deprecate("chdir('') or chdir(undef) as chdir()");
3452             tmps = SvPV_nolen_const(*svp);
3453         }
3454         else {
3455             PUSHi(0);
3456             TAINT_PROPER("chdir");
3457             RETURN;
3458         }
3459     }
3460
3461     TAINT_PROPER("chdir");
3462     if (gv) {
3463 #ifdef HAS_FCHDIR
3464         IO* const io = GvIO(gv);
3465         if (io) {
3466             if (IoDIRP(io)) {
3467                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3468             } else if (IoIFP(io)) {
3469                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3470             }
3471             else {
3472                 report_evil_fh(gv);
3473                 SETERRNO(EBADF, RMS_IFI);
3474                 PUSHi(0);
3475             }
3476         }
3477         else {
3478             report_evil_fh(gv);
3479             SETERRNO(EBADF,RMS_IFI);
3480             PUSHi(0);
3481         }
3482 #else
3483         DIE(aTHX_ PL_no_func, "fchdir");
3484 #endif
3485     }
3486     else 
3487         PUSHi( PerlDir_chdir(tmps) >= 0 );
3488 #ifdef VMS
3489     /* Clear the DEFAULT element of ENV so we'll get the new value
3490      * in the future. */
3491     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3492 #endif
3493     RETURN;
3494 }
3495
3496 PP(pp_chown)
3497 {
3498     dVAR; dSP; dMARK; dTARGET;
3499     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3500
3501     SP = MARK;
3502     XPUSHi(value);
3503     RETURN;
3504 }
3505
3506 PP(pp_chroot)
3507 {
3508 #ifdef HAS_CHROOT
3509     dVAR; dSP; dTARGET;
3510     char * const tmps = POPpx;
3511     TAINT_PROPER("chroot");
3512     PUSHi( chroot(tmps) >= 0 );
3513     RETURN;
3514 #else
3515     DIE(aTHX_ PL_no_func, "chroot");
3516 #endif
3517 }
3518
3519 PP(pp_rename)
3520 {
3521     dVAR; dSP; dTARGET;
3522     int anum;
3523     const char * const tmps2 = POPpconstx;
3524     const char * const tmps = SvPV_nolen_const(TOPs);
3525     TAINT_PROPER("rename");
3526 #ifdef HAS_RENAME
3527     anum = PerlLIO_rename(tmps, tmps2);
3528 #else
3529     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3530         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3531             anum = 1;
3532         else {
3533             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3534                 (void)UNLINK(tmps2);
3535             if (!(anum = link(tmps, tmps2)))
3536                 anum = UNLINK(tmps);
3537         }
3538     }
3539 #endif
3540     SETi( anum >= 0 );
3541     RETURN;
3542 }
3543
3544 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3545 PP(pp_link)
3546 {
3547     dVAR; dSP; dTARGET;
3548     const int op_type = PL_op->op_type;
3549     int result;
3550
3551 #  ifndef HAS_LINK
3552     if (op_type == OP_LINK)
3553         DIE(aTHX_ PL_no_func, "link");
3554 #  endif
3555 #  ifndef HAS_SYMLINK
3556     if (op_type == OP_SYMLINK)
3557         DIE(aTHX_ PL_no_func, "symlink");
3558 #  endif
3559
3560     {
3561         const char * const tmps2 = POPpconstx;
3562         const char * const tmps = SvPV_nolen_const(TOPs);
3563         TAINT_PROPER(PL_op_desc[op_type]);
3564         result =
3565 #  if defined(HAS_LINK)
3566 #    if defined(HAS_SYMLINK)
3567             /* Both present - need to choose which.  */
3568             (op_type == OP_LINK) ?
3569             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3570 #    else
3571     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3572         PerlLIO_link(tmps, tmps2);
3573 #    endif
3574 #  else
3575 #    if defined(HAS_SYMLINK)
3576     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3577         symlink(tmps, tmps2);
3578 #    endif
3579 #  endif
3580     }
3581
3582     SETi( result >= 0 );
3583     RETURN;
3584 }
3585 #else
3586 PP(pp_link)
3587 {
3588     /* Have neither.  */
3589     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3590 }
3591 #endif
3592
3593 PP(pp_readlink)
3594 {
3595     dVAR;
3596     dSP;
3597 #ifdef HAS_SYMLINK
3598     dTARGET;
3599     const char *tmps;
3600     char buf[MAXPATHLEN];
3601     int len;
3602
3603     TAINT;
3604     tmps = POPpconstx;
3605     len = readlink(tmps, buf, sizeof(buf) - 1);
3606     if (len < 0)
3607         RETPUSHUNDEF;
3608     PUSHp(buf, len);
3609     RETURN;
3610 #else
3611     EXTEND(SP, 1);
3612     RETSETUNDEF;                /* just pretend it's a normal file */
3613 #endif
3614 }
3615
3616 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3617 STATIC int
3618 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3619 {
3620     char * const save_filename = filename;
3621     char *cmdline;
3622     char *s;
3623     PerlIO *myfp;
3624     int anum = 1;
3625     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3626
3627     PERL_ARGS_ASSERT_DOONELINER;
3628
3629     Newx(cmdline, size, char);
3630     my_strlcpy(cmdline, cmd, size);
3631     my_strlcat(cmdline, " ", size);
3632     for (s = cmdline + strlen(cmdline); *filename; ) {
3633         *s++ = '\\';
3634         *s++ = *filename++;
3635     }
3636     if (s - cmdline < size)
3637         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3638     myfp = PerlProc_popen(cmdline, "r");
3639     Safefree(cmdline);
3640
3641     if (myfp) {
3642         SV * const tmpsv = sv_newmortal();
3643         /* Need to save/restore 'PL_rs' ?? */
3644         s = sv_gets(tmpsv, myfp, 0);
3645         (void)PerlProc_pclose(myfp);
3646         if (s != NULL) {
3647             int e;
3648             for (e = 1;
3649 #ifdef HAS_SYS_ERRLIST
3650                  e <= sys_nerr
3651 #endif
3652                  ; e++)
3653             {
3654                 /* you don't see this */
3655                 const char * const errmsg = Strerror(e) ;
3656                 if (!errmsg)
3657                     break;
3658                 if (instr(s, errmsg)) {
3659                     SETERRNO(e,0);
3660                     return 0;
3661                 }
3662             }
3663             SETERRNO(0,0);
3664 #ifndef EACCES
3665 #define EACCES EPERM
3666 #endif
3667             if (instr(s, "cannot make"))
3668                 SETERRNO(EEXIST,RMS_FEX);
3669             else if (instr(s, "existing file"))
3670                 SETERRNO(EEXIST,RMS_FEX);
3671             else if (instr(s, "ile exists"))
3672                 SETERRNO(EEXIST,RMS_FEX);
3673             else if (instr(s, "non-exist"))
3674                 SETERRNO(ENOENT,RMS_FNF);
3675             else if (instr(s, "does not exist"))
3676                 SETERRNO(ENOENT,RMS_FNF);
3677             else if (instr(s, "not empty"))
3678                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3679             else if (instr(s, "cannot access"))
3680                 SETERRNO(EACCES,RMS_PRV);
3681             else
3682                 SETERRNO(EPERM,RMS_PRV);
3683             return 0;
3684         }
3685         else {  /* some mkdirs return no failure indication */
3686             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3687             if (PL_op->op_type == OP_RMDIR)
3688                 anum = !anum;
3689             if (anum)
3690                 SETERRNO(0,0);
3691             else
3692                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3693         }
3694         return anum;
3695     }
3696     else
3697         return 0;
3698 }
3699 #endif
3700
3701 /* This macro removes trailing slashes from a directory name.
3702  * Different operating and file systems take differently to
3703  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3704  * any number of trailing slashes should be allowed.
3705  * Thusly we snip them away so that even non-conforming
3706  * systems are happy.
3707  * We should probably do this "filtering" for all
3708  * the functions that expect (potentially) directory names:
3709  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3710  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3711
3712 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3713     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3714         do { \
3715             (len)--; \
3716         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3717         (tmps) = savepvn((tmps), (len)); \
3718         (copy) = TRUE; \
3719     }
3720
3721 PP(pp_mkdir)
3722 {
3723     dVAR; dSP; dTARGET;
3724     STRLEN len;
3725     const char *tmps;
3726     bool copy = FALSE;
3727     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3728
3729     TRIMSLASHES(tmps,len,copy);
3730
3731     TAINT_PROPER("mkdir");
3732 #ifdef HAS_MKDIR
3733     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3734 #else
3735     {
3736     int oldumask;
3737     SETi( dooneliner("mkdir", tmps) );
3738     oldumask = PerlLIO_umask(0);
3739     PerlLIO_umask(oldumask);
3740     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3741     }
3742 #endif
3743     if (copy)
3744         Safefree(tmps);
3745     RETURN;
3746 }
3747
3748 PP(pp_rmdir)
3749 {
3750     dVAR; dSP; dTARGET;
3751     STRLEN len;
3752     const char *tmps;
3753     bool copy = FALSE;
3754
3755     TRIMSLASHES(tmps,len,copy);
3756     TAINT_PROPER("rmdir");
3757 #ifdef HAS_RMDIR
3758     SETi( PerlDir_rmdir(tmps) >= 0 );
3759 #else
3760     SETi( dooneliner("rmdir", tmps) );
3761 #endif
3762     if (copy)
3763         Safefree(tmps);
3764     RETURN;
3765 }
3766
3767 /* Directory calls. */
3768
3769 PP(pp_open_dir)
3770 {
3771 #if defined(Direntry_t) && defined(HAS_READDIR)
3772     dVAR; dSP;
3773     const char * const dirname = POPpconstx;
3774     GV * const gv = MUTABLE_GV(POPs);
3775     IO * const io = GvIOn(gv);
3776
3777     if ((IoIFP(io) || IoOFP(io)))
3778         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3779                          "Opening filehandle %"HEKf" also as a directory",
3780                              HEKfARG(GvENAME_HEK(gv)) );
3781     if (IoDIRP(io))
3782         PerlDir_close(IoDIRP(io));
3783     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3784         goto nope;
3785
3786     RETPUSHYES;
3787 nope:
3788     if (!errno)
3789         SETERRNO(EBADF,RMS_DIR);
3790     RETPUSHUNDEF;
3791 #else
3792     DIE(aTHX_ PL_no_dir_func, "opendir");
3793 #endif
3794 }
3795
3796 PP(pp_readdir)
3797 {
3798 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3799     DIE(aTHX_ PL_no_dir_func, "readdir");
3800 #else
3801 #if !defined(I_DIRENT) && !defined(VMS)
3802     Direntry_t *readdir (DIR *);
3803 #endif
3804     dVAR;
3805     dSP;
3806
3807     SV *sv;
3808     const I32 gimme = GIMME;
3809     GV * const gv = MUTABLE_GV(POPs);
3810     const Direntry_t *dp;
3811     IO * const io = GvIOn(gv);
3812
3813     if (!IoDIRP(io)) {
3814         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3815                        "readdir() attempted on invalid dirhandle %"HEKf,
3816                             HEKfARG(GvENAME_HEK(gv)));
3817         goto nope;
3818     }
3819
3820     do {
3821         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3822         if (!dp)
3823             break;
3824 #ifdef DIRNAMLEN
3825         sv = newSVpvn(dp->d_name, dp->d_namlen);
3826 #else
3827         sv = newSVpv(dp->d_name, 0);
3828 #endif
3829         if (!(IoFLAGS(io) & IOf_UNTAINT))
3830             SvTAINTED_on(sv);
3831         mXPUSHs(sv);
3832     } while (gimme == G_ARRAY);
3833
3834     if (!dp && gimme != G_ARRAY)
3835         RETPUSHUNDEF;
3836
3837     RETURN;
3838
3839 nope:
3840     if (!errno)
3841         SETERRNO(EBADF,RMS_ISI);
3842     if (GIMME == G_ARRAY)
3843         RETURN;
3844     else
3845         RETPUSHUNDEF;
3846 #endif
3847 }
3848
3849 PP(pp_telldir)
3850 {
3851 #if defined(HAS_TELLDIR) || defined(telldir)
3852     dVAR; dSP; dTARGET;
3853  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3854  /* XXX netbsd still seemed to.
3855     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3856     --JHI 1999-Feb-02 */
3857 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3858     long telldir (DIR *);
3859 # endif
3860     GV * const gv = MUTABLE_GV(POPs);
3861     IO * const io = GvIOn(gv);
3862
3863     if (!IoDIRP(io)) {
3864         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3865                        "telldir() attempted on invalid dirhandle %"HEKf,
3866                             HEKfARG(GvENAME_HEK(gv)));
3867         goto nope;
3868     }
3869
3870     PUSHi( PerlDir_tell(IoDIRP(io)) );
3871     RETURN;
3872 nope:
3873     if (!errno)
3874         SETERRNO(EBADF,RMS_ISI);
3875     RETPUSHUNDEF;
3876 #else
3877     DIE(aTHX_ PL_no_dir_func, "telldir");
3878 #endif
3879 }
3880
3881 PP(pp_seekdir)
3882 {
3883 #if defined(HAS_SEEKDIR) || defined(seekdir)
3884     dVAR; dSP;
3885     const long along = POPl;
3886     GV * const gv = MUTABLE_GV(POPs);
3887     IO * const io = GvIOn(gv);
3888
3889     if (!IoDIRP(io)) {
3890         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3891                        "seekdir() attempted on invalid dirhandle %"HEKf,
3892                                 HEKfARG(GvENAME_HEK(gv)));
3893         goto nope;
3894     }
3895     (void)PerlDir_seek(IoDIRP(io), along);
3896
3897     RETPUSHYES;
3898 nope:
3899     if (!errno)
3900         SETERRNO(EBADF,RMS_ISI);
3901     RETPUSHUNDEF;
3902 #else
3903     DIE(aTHX_ PL_no_dir_func, "seekdir");
3904 #endif
3905 }
3906
3907 PP(pp_rewinddir)
3908 {
3909 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3910     dVAR; dSP;
3911     GV * const gv = MUTABLE_GV(POPs);
3912     IO * const io = GvIOn(gv);
3913
3914     if (!IoDIRP(io)) {
3915         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3916                        "rewinddir() attempted on invalid dirhandle %"HEKf,
3917                                 HEKfARG(GvENAME_HEK(gv)));
3918         goto nope;
3919     }
3920     (void)PerlDir_rewind(IoDIRP(io));
3921     RETPUSHYES;
3922 nope:
3923     if (!errno)
3924         SETERRNO(EBADF,RMS_ISI);
3925     RETPUSHUNDEF;
3926 #else
3927     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3928 #endif
3929 }
3930
3931 PP(pp_closedir)
3932 {
3933 #if defined(Direntry_t) && defined(HAS_READDIR)
3934     dVAR; dSP;
3935     GV * const gv = MUTABLE_GV(POPs);
3936     IO * const io = GvIOn(gv);
3937
3938     if (!IoDIRP(io)) {
3939         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3940                        "closedir() attempted on invalid dirhandle %"HEKf,
3941                                 HEKfARG(GvENAME_HEK(gv)));
3942         goto nope;
3943     }
3944 #ifdef VOID_CLOSEDIR
3945     PerlDir_close(IoDIRP(io));
3946 #else
3947     if (PerlDir_close(IoDIRP(io)) < 0) {
3948         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3949         goto nope;
3950     }
3951 #endif
3952     IoDIRP(io) = 0;
3953
3954     RETPUSHYES;
3955 nope:
3956     if (!errno)
3957         SETERRNO(EBADF,RMS_IFI);
3958     RETPUSHUNDEF;
3959 #else
3960     DIE(aTHX_ PL_no_dir_func, "closedir");
3961 #endif
3962 }
3963
3964 /* Process control. */
3965
3966 PP(pp_fork)
3967 {
3968 #ifdef HAS_FORK
3969     dVAR; dSP; dTARGET;
3970     Pid_t childpid;
3971 #ifdef HAS_SIGPROCMASK
3972     sigset_t oldmask, newmask;
3973 #endif
3974
3975     EXTEND(SP, 1);
3976     PERL_FLUSHALL_FOR_CHILD;
3977 #ifdef HAS_SIGPROCMASK
3978     sigfillset(&newmask);
3979     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
3980 #endif
3981     childpid = PerlProc_fork();
3982     if (childpid == 0) {
3983         int sig;
3984         PL_sig_pending = 0;
3985         if (PL_psig_pend)
3986             for (sig = 1; sig < SIG_SIZE; sig++)
3987                 PL_psig_pend[sig] = 0;
3988     }
3989 #ifdef HAS_SIGPROCMASK
3990     {
3991         dSAVE_ERRNO;
3992         sigprocmask(SIG_SETMASK, &oldmask, NULL);
3993         RESTORE_ERRNO;
3994     }
3995 #endif
3996     if (childpid < 0)
3997         RETPUSHUNDEF;
3998     if (!childpid) {
3999 #ifdef PERL_USES_PL_PIDSTATUS
4000         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4001 #endif
4002     }
4003     PUSHi(childpid);
4004     RETURN;
4005 #else
4006 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4007     dSP; dTARGET;
4008     Pid_t childpid;
4009
4010     EXTEND(SP, 1);
4011     PERL_FLUSHALL_FOR_CHILD;
4012     childpid = PerlProc_fork();
4013     if (childpid == -1)
4014         RETPUSHUNDEF;
4015     PUSHi(childpid);
4016     RETURN;
4017 #  else
4018     DIE(aTHX_ PL_no_func, "fork");
4019 #  endif
4020 #endif
4021 }
4022
4023 PP(pp_wait)
4024 {
4025 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4026     dVAR; dSP; dTARGET;
4027     Pid_t childpid;
4028     int argflags;
4029
4030     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4031         childpid = wait4pid(-1, &argflags, 0);
4032     else {
4033         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4034                errno == EINTR) {
4035           PERL_ASYNC_CHECK();
4036         }
4037     }
4038 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4039     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4040     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4041 #  else
4042     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4043 #  endif
4044     XPUSHi(childpid);
4045     RETURN;
4046 #else
4047     DIE(aTHX_ PL_no_func, "wait");
4048 #endif
4049 }
4050
4051 PP(pp_waitpid)
4052 {
4053 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4054     dVAR; dSP; dTARGET;
4055     const int optype = POPi;
4056     const Pid_t pid = TOPi;
4057     Pid_t result;
4058     int argflags;
4059
4060     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4061         result = wait4pid(pid, &argflags, optype);
4062     else {
4063         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4064                errno == EINTR) {
4065           PERL_ASYNC_CHECK();
4066         }
4067     }
4068 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4069     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4070     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4071 #  else
4072     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4073 #  endif
4074     SETi(result);
4075     RETURN;
4076 #else
4077     DIE(aTHX_ PL_no_func, "waitpid");
4078 #endif
4079 }
4080
4081 PP(pp_system)
4082 {
4083     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4084 #if defined(__LIBCATAMOUNT__)
4085     PL_statusvalue = -1;
4086     SP = ORIGMARK;
4087     XPUSHi(-1);
4088 #else
4089     I32 value;
4090     int result;
4091
4092     if (TAINTING_get) {
4093         TAINT_ENV();
4094         while (++MARK <= SP) {
4095             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4096             if (TAINT_get)
4097                 break;
4098         }
4099         MARK = ORIGMARK;
4100         TAINT_PROPER("system");
4101     }
4102     PERL_FLUSHALL_FOR_CHILD;
4103 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4104     {
4105         Pid_t childpid;
4106         int pp[2];
4107         I32 did_pipes = 0;
4108 #ifdef HAS_SIGPROCMASK
4109         sigset_t newset, oldset;
4110 #endif
4111
4112         if (PerlProc_pipe(pp) >= 0)
4113             did_pipes = 1;
4114 #ifdef HAS_SIGPROCMASK
4115         sigemptyset(&newset);
4116         sigaddset(&newset, SIGCHLD);
4117         sigprocmask(SIG_BLOCK, &newset, &oldset);
4118 #endif
4119         while ((childpid = PerlProc_fork()) == -1) {
4120             if (errno != EAGAIN) {
4121                 value = -1;
4122                 SP = ORIGMARK;
4123                 XPUSHi(value);
4124                 if (did_pipes) {
4125                     PerlLIO_close(pp[0]);
4126                     PerlLIO_close(pp[1]);
4127                 }
4128 #ifdef HAS_SIGPROCMASK
4129                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4130 #endif
4131                 RETURN;
4132             }
4133             sleep(5);
4134         }
4135         if (childpid > 0) {
4136             Sigsave_t ihand,qhand; /* place to save signals during system() */
4137             int status;
4138
4139             if (did_pipes)
4140                 PerlLIO_close(pp[1]);
4141 #ifndef PERL_MICRO
4142             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4143             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4144 #endif
4145             do {
4146                 result = wait4pid(childpid, &status, 0);
4147             } while (result == -1 && errno == EINTR);
4148 #ifndef PERL_MICRO
4149 #ifdef HAS_SIGPROCMASK
4150             sigprocmask(SIG_SETMASK, &oldset, NULL);
4151 #endif
4152             (void)rsignal_restore(SIGINT, &ihand);
4153             (void)rsignal_restore(SIGQUIT, &qhand);
4154 #endif
4155             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4156             do_execfree();      /* free any memory child malloced on fork */
4157             SP = ORIGMARK;
4158             if (did_pipes) {
4159                 int errkid;
4160                 unsigned n = 0;
4161                 SSize_t n1;
4162
4163                 while (n < sizeof(int)) {
4164                     n1 = PerlLIO_read(pp[0],
4165                                       (void*)(((char*)&errkid)+n),
4166                                       (sizeof(int)) - n);
4167                     if (n1 <= 0)
4168                         break;
4169                     n += n1;
4170                 }
4171                 PerlLIO_close(pp[0]);
4172                 if (n) {                        /* Error */
4173                     if (n != sizeof(int))
4174                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4175                     errno = errkid;             /* Propagate errno from kid */
4176                     STATUS_NATIVE_CHILD_SET(-1);
4177                 }
4178             }
4179             XPUSHi(STATUS_CURRENT);
4180             RETURN;
4181         }
4182 #ifdef HAS_SIGPROCMASK
4183         sigprocmask(SIG_SETMASK, &oldset, NULL);
4184 #endif
4185         if (did_pipes) {
4186             PerlLIO_close(pp[0]);
4187 #if defined(HAS_FCNTL) && defined(F_SETFD)
4188             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4189 #endif
4190         }
4191         if (PL_op->op_flags & OPf_STACKED) {
4192             SV * const really = *++MARK;
4193             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4194         }
4195         else if (SP - MARK != 1)
4196             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4197         else {
4198             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4199         }
4200         PerlProc__exit(-1);
4201     }
4202 #else /* ! FORK or VMS or OS/2 */
4203     PL_statusvalue = 0;
4204     result = 0;
4205     if (PL_op->op_flags & OPf_STACKED) {
4206         SV * const really = *++MARK;
4207 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4208         value = (I32)do_aspawn(really, MARK, SP);
4209 #  else
4210         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4211 #  endif
4212     }
4213     else if (SP - MARK != 1) {
4214 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4215         value = (I32)do_aspawn(NULL, MARK, SP);
4216 #  else
4217         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4218 #  endif
4219     }
4220     else {
4221         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4222     }
4223     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4224         result = 1;
4225     STATUS_NATIVE_CHILD_SET(value);
4226     do_execfree();
4227     SP = ORIGMARK;
4228     XPUSHi(result ? value : STATUS_CURRENT);
4229 #endif /* !FORK or VMS or OS/2 */
4230 #endif
4231     RETURN;
4232 }
4233
4234 PP(pp_exec)
4235 {
4236     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4237     I32 value;
4238
4239     if (TAINTING_get) {
4240         TAINT_ENV();
4241         while (++MARK <= SP) {
4242             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4243             if (TAINT_get)
4244                 break;
4245         }
4246         MARK = ORIGMARK;
4247         TAINT_PROPER("exec");
4248     }
4249     PERL_FLUSHALL_FOR_CHILD;
4250     if (PL_op->op_flags & OPf_STACKED) {
4251         SV * const really = *++MARK;
4252         value = (I32)do_aexec(really, MARK, SP);
4253     }
4254     else if (SP - MARK != 1)
4255 #ifdef VMS
4256         value = (I32)vms_do_aexec(NULL, MARK, SP);
4257 #else
4258         value = (I32)do_aexec(NULL, MARK, SP);
4259 #endif
4260     else {
4261 #ifdef VMS
4262         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4263 #else
4264         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4265 #endif
4266     }
4267
4268     SP = ORIGMARK;
4269     XPUSHi(value);
4270     RETURN;
4271 }
4272
4273 PP(pp_getppid)
4274 {
4275 #ifdef HAS_GETPPID
4276     dVAR; dSP; dTARGET;
4277     XPUSHi( getppid() );
4278     RETURN;
4279 #else
4280     DIE(aTHX_ PL_no_func, "getppid");
4281 #endif
4282 }
4283
4284 PP(pp_getpgrp)
4285 {
4286 #ifdef HAS_GETPGRP
4287     dVAR; dSP; dTARGET;
4288     Pid_t pgrp;
4289     const Pid_t pid =
4290         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4291
4292 #ifdef BSD_GETPGRP
4293     pgrp = (I32)BSD_GETPGRP(pid);
4294 #else
4295     if (pid != 0 && pid != PerlProc_getpid())
4296         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4297     pgrp = getpgrp();
4298 #endif
4299     XPUSHi(pgrp);
4300     RETURN;
4301 #else
4302     DIE(aTHX_ PL_no_func, "getpgrp()");
4303 #endif
4304 }
4305
4306 PP(pp_setpgrp)
4307 {
4308 #ifdef HAS_SETPGRP
4309     dVAR; dSP; dTARGET;
4310     Pid_t pgrp;
4311     Pid_t pid;
4312     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4313     if (MAXARG > 0) pid = TOPs && TOPi;
4314     else {
4315         pid = 0;
4316         XPUSHi(-1);
4317     }
4318
4319     TAINT_PROPER("setpgrp");
4320 #ifdef BSD_SETPGRP
4321     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4322 #else
4323     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4324         || (pid != 0 && pid != PerlProc_getpid()))
4325     {
4326         DIE(aTHX_ "setpgrp can't take arguments");
4327     }
4328     SETi( setpgrp() >= 0 );
4329 #endif /* USE_BSDPGRP */
4330     RETURN;
4331 #else
4332     DIE(aTHX_ PL_no_func, "setpgrp()");
4333 #endif
4334 }
4335
4336 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4337 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4338 #else
4339 #  define PRIORITY_WHICH_T(which) which
4340 #endif
4341
4342 PP(pp_getpriority)
4343 {
4344 #ifdef HAS_GETPRIORITY
4345     dVAR; dSP; dTARGET;
4346     const int who = POPi;
4347     const int which = TOPi;
4348     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4349     RETURN;
4350 #else
4351     DIE(aTHX_ PL_no_func, "getpriority()");
4352 #endif
4353 }
4354
4355 PP(pp_setpriority)
4356 {
4357 #ifdef HAS_SETPRIORITY
4358     dVAR; dSP; dTARGET;
4359     const int niceval = POPi;
4360     const int who = POPi;
4361     const int which = TOPi;
4362     TAINT_PROPER("setpriority");
4363     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4364     RETURN;
4365 #else
4366     DIE(aTHX_ PL_no_func, "setpriority()");
4367 #endif
4368 }
4369
4370 #undef PRIORITY_WHICH_T
4371
4372 /* Time calls. */
4373
4374 PP(pp_time)
4375 {
4376     dVAR; dSP; dTARGET;
4377 #ifdef BIG_TIME
4378     XPUSHn( time(NULL) );
4379 #else
4380     XPUSHi( time(NULL) );
4381 #endif
4382     RETURN;
4383 }
4384
4385 PP(pp_tms)
4386 {
4387 #ifdef HAS_TIMES
4388     dVAR;
4389     dSP;
4390     EXTEND(SP, 4);
4391 #ifndef VMS
4392     (void)PerlProc_times(&PL_timesbuf);
4393 #else
4394     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4395                                                    /* struct tms, though same data   */
4396                                                    /* is returned.                   */
4397 #endif
4398
4399     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4400     if (GIMME == G_ARRAY) {
4401         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4402         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4403         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4404     }
4405     RETURN;
4406 #else
4407 #   ifdef PERL_MICRO
4408     dSP;
4409     mPUSHn(0.0);
4410     EXTEND(SP, 4);
4411     if (GIMME == G_ARRAY) {
4412          mPUSHn(0.0);
4413          mPUSHn(0.0);
4414          mPUSHn(0.0);
4415     }
4416     RETURN;
4417 #   else
4418     DIE(aTHX_ "times not implemented");
4419 #   endif
4420 #endif /* HAS_TIMES */
4421 }
4422
4423 /* The 32 bit int year limits the times we can represent to these
4424    boundaries with a few days wiggle room to account for time zone
4425    offsets
4426 */
4427 /* Sat Jan  3 00:00:00 -2147481748 */
4428 #define TIME_LOWER_BOUND -67768100567755200.0
4429 /* Sun Dec 29 12:00:00  2147483647 */
4430 #define TIME_UPPER_BOUND  67767976233316800.0
4431
4432 PP(pp_gmtime)
4433 {
4434     dVAR;
4435     dSP;
4436     Time64_T when;
4437     struct TM tmbuf;
4438     struct TM *err;
4439     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4440     static const char * const dayname[] =
4441         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4442     static const char * const monname[] =
4443         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4444          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4445
4446     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4447         time_t now;
4448         (void)time(&now);
4449         when = (Time64_T)now;
4450     }
4451     else {
4452         NV input = Perl_floor(POPn);
4453         when = (Time64_T)input;
4454         if (when != input) {
4455             /* diag_listed_as: gmtime(%f) too large */
4456             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4457                            "%s(%.0" NVff ") too large", opname, input);
4458         }
4459     }
4460
4461     if ( TIME_LOWER_BOUND > when ) {
4462         /* diag_listed_as: gmtime(%f) too small */
4463         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4464                        "%s(%.0" NVff ") too small", opname, when);
4465         err = NULL;
4466     }
4467     else if( when > TIME_UPPER_BOUND ) {
4468         /* diag_listed_as: gmtime(%f) too small */
4469         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4470                        "%s(%.0" NVff ") too large", opname, when);
4471         err = NULL;
4472     }
4473     else {
4474         if (PL_op->op_type == OP_LOCALTIME)
4475             err = S_localtime64_r(&when, &tmbuf);
4476         else
4477             err = S_gmtime64_r(&when, &tmbuf);
4478     }
4479
4480     if (err == NULL) {
4481         /* XXX %lld broken for quads */
4482         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4483                        "%s(%.0" NVff ") failed", opname, when);
4484     }
4485
4486     if (GIMME != G_ARRAY) {     /* scalar context */
4487         SV *tsv;
4488         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4489         double year = (double)tmbuf.tm_year + 1900;
4490
4491         EXTEND(SP, 1);
4492         EXTEND_MORTAL(1);
4493         if (err == NULL)
4494             RETPUSHUNDEF;
4495
4496         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4497                             dayname[tmbuf.tm_wday],
4498                             monname[tmbuf.tm_mon],
4499                             tmbuf.tm_mday,
4500                             tmbuf.tm_hour,
4501                             tmbuf.tm_min,
4502                             tmbuf.tm_sec,
4503                             year);
4504         mPUSHs(tsv);
4505     }
4506     else {                      /* list context */
4507         if ( err == NULL )
4508             RETURN;
4509
4510         EXTEND(SP, 9);
4511         EXTEND_MORTAL(9);
4512         mPUSHi(tmbuf.tm_sec);
4513         mPUSHi(tmbuf.tm_min);
4514         mPUSHi(tmbuf.tm_hour);
4515         mPUSHi(tmbuf.tm_mday);
4516         mPUSHi(tmbuf.tm_mon);
4517         mPUSHn(tmbuf.tm_year);
4518         mPUSHi(tmbuf.tm_wday);
4519         mPUSHi(tmbuf.tm_yday);
4520         mPUSHi(tmbuf.tm_isdst);
4521     }
4522     RETURN;
4523 }
4524
4525 PP(pp_alarm)
4526 {
4527 #ifdef HAS_ALARM
4528     dVAR; dSP; dTARGET;
4529     int anum;
4530     anum = POPi;
4531     anum = alarm((unsigned int)anum);
4532     if (anum < 0)
4533         RETPUSHUNDEF;
4534     PUSHi(anum);
4535     RETURN;
4536 #else
4537     DIE(aTHX_ PL_no_func, "alarm");
4538 #endif
4539 }
4540
4541 PP(pp_sleep)
4542 {
4543     dVAR; dSP; dTARGET;
4544     I32 duration;
4545     Time_t lasttime;
4546     Time_t when;
4547
4548     (void)time(&lasttime);
4549     if (MAXARG < 1 || (!TOPs && !POPs))
4550         PerlProc_pause();
4551     else {
4552         duration = POPi;
4553         PerlProc_sleep((unsigned int)duration);
4554     }
4555     (void)time(&when);
4556     XPUSHi(when - lasttime);
4557     RETURN;
4558 }
4559
4560 /* Shared memory. */
4561 /* Merged with some message passing. */
4562
4563 PP(pp_shmwrite)
4564 {
4565 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4566     dVAR; dSP; dMARK; dTARGET;
4567     const int op_type = PL_op->op_type;
4568     I32 value;
4569
4570     switch (op_type) {
4571     case OP_MSGSND:
4572         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4573         break;
4574     case OP_MSGRCV:
4575         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4576         break;
4577     case OP_SEMOP:
4578         value = (I32)(do_semop(MARK, SP) >= 0);
4579         break;
4580     default:
4581         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4582         break;
4583     }
4584
4585     SP = MARK;
4586     PUSHi(value);
4587     RETURN;
4588 #else
4589     return Perl_pp_semget(aTHX);
4590 #endif
4591 }
4592
4593 /* Semaphores. */
4594
4595 PP(pp_semget)
4596 {
4597 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4598     dVAR; dSP; dMARK; dTARGET;
4599     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4600     SP = MARK;
4601     if (anum == -1)
4602         RETPUSHUNDEF;
4603     PUSHi(anum);
4604     RETURN;
4605 #else
4606     DIE(aTHX_ "System V IPC is not implemented on this machine");
4607 #endif
4608 }
4609
4610 PP(pp_semctl)
4611 {
4612 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4613     dVAR; dSP; dMARK; dTARGET;
4614     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4615     SP = MARK;
4616     if (anum == -1)
4617         RETSETUNDEF;
4618     if (anum != 0) {
4619         PUSHi(anum);
4620     }
4621     else {
4622         PUSHp(zero_but_true, ZBTLEN);
4623     }
4624     RETURN;
4625 #else
4626     return Perl_pp_semget(aTHX);
4627 #endif
4628 }
4629
4630 /* I can't const this further without getting warnings about the types of
4631    various arrays passed in from structures.  */
4632 static SV *
4633 S_space_join_names_mortal(pTHX_ char *const *array)
4634 {
4635     SV *target;
4636
4637     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4638
4639     if (array && *array) {
4640         target = newSVpvs_flags("", SVs_TEMP);
4641         while (1) {
4642             sv_catpv(target, *array);
4643             if (!*++array)
4644                 break;
4645             sv_catpvs(target, " ");
4646         }
4647     } else {
4648         target = sv_mortalcopy(&PL_sv_no);
4649     }
4650     return target;
4651 }
4652
4653 /* Get system info. */
4654
4655 PP(pp_ghostent)
4656 {
4657 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4658     dVAR; dSP;
4659     I32 which = PL_op->op_type;
4660     char **elem;
4661     SV *sv;
4662 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4663     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4664     struct hostent *gethostbyname(Netdb_name_t);
4665     struct hostent *gethostent(void);
4666 #endif
4667     struct hostent *hent = NULL;
4668     unsigned long len;
4669
4670     EXTEND(SP, 10);
4671     if (which == OP_GHBYNAME) {
4672 #ifdef HAS_GETHOSTBYNAME
4673         const char* const name = POPpbytex;
4674         hent = PerlSock_gethostbyname(name);
4675 #else
4676         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4677 #endif
4678     }
4679     else if (which == OP_GHBYADDR) {
4680 #ifdef HAS_GETHOSTBYADDR
4681         const int addrtype = POPi;
4682         SV * const addrsv = POPs;
4683         STRLEN addrlen;
4684         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4685
4686         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4687 #else
4688         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4689 #endif
4690     }
4691     else
4692 #ifdef HAS_GETHOSTENT
4693         hent = PerlSock_gethostent();
4694 #else
4695         DIE(aTHX_ PL_no_sock_func, "gethostent");
4696 #endif
4697
4698 #ifdef HOST_NOT_FOUND
4699         if (!hent) {
4700 #ifdef USE_REENTRANT_API
4701 #   ifdef USE_GETHOSTENT_ERRNO
4702             h_errno = PL_reentrant_buffer->_gethostent_errno;
4703 #   endif
4704 #endif
4705             STATUS_UNIX_SET(h_errno);
4706         }
4707 #endif
4708
4709     if (GIMME != G_ARRAY) {
4710         PUSHs(sv = sv_newmortal());
4711         if (hent) {
4712             if (which == OP_GHBYNAME) {
4713                 if (hent->h_addr)
4714                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4715             }
4716             else
4717                 sv_setpv(sv, (char*)hent->h_name);
4718         }
4719         RETURN;
4720     }
4721
4722     if (hent) {
4723         mPUSHs(newSVpv((char*)hent->h_name, 0));
4724         PUSHs(space_join_names_mortal(hent->h_aliases));
4725         mPUSHi(hent->h_addrtype);
4726         len = hent->h_length;
4727         mPUSHi(len);
4728 #ifdef h_addr
4729         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4730             mXPUSHp(*elem, len);
4731         }
4732 #else
4733         if (hent->h_addr)
4734             mPUSHp(hent->h_addr, len);
4735         else
4736             PUSHs(sv_mortalcopy(&PL_sv_no));
4737 #endif /* h_addr */
4738     }
4739     RETURN;
4740 #else
4741     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4742 #endif
4743 }
4744
4745 PP(pp_gnetent)
4746 {
4747 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4748     dVAR; dSP;
4749     I32 which = PL_op->op_type;
4750     SV *sv;
4751 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4752     struct netent *getnetbyaddr(Netdb_net_t, int);
4753     struct netent *getnetbyname(Netdb_name_t);
4754     struct netent *getnetent(void);
4755 #endif
4756     struct netent *nent;
4757
4758     if (which == OP_GNBYNAME){
4759 #ifdef HAS_GETNETBYNAME
4760         const char * const name = POPpbytex;
4761         nent = PerlSock_getnetbyname(name);
4762 #else
4763         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4764 #endif
4765     }
4766     else if (which == OP_GNBYADDR) {
4767 #ifdef HAS_GETNETBYADDR
4768         const int addrtype = POPi;
4769         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4770         nent = PerlSock_getnetbyaddr(addr, addrtype);
4771 #else
4772         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4773 #endif
4774     }
4775     else
4776 #ifdef HAS_GETNETENT
4777         nent = PerlSock_getnetent();
4778 #else
4779         DIE(aTHX_ PL_no_sock_func, "getnetent");
4780 #endif
4781
4782 #ifdef HOST_NOT_FOUND
4783         if (!nent) {
4784 #ifdef USE_REENTRANT_API
4785 #   ifdef USE_GETNETENT_ERRNO
4786              h_errno = PL_reentrant_buffer->_getnetent_errno;
4787 #   endif
4788 #endif
4789             STATUS_UNIX_SET(h_errno);
4790         }
4791 #endif
4792
4793     EXTEND(SP, 4);
4794     if (GIMME != G_ARRAY) {
4795         PUSHs(sv = sv_newmortal());
4796         if (nent) {
4797             if (which == OP_GNBYNAME)
4798                 sv_setiv(sv, (IV)nent->n_net);
4799             else
4800                 sv_setpv(sv, nent->n_name);
4801         }
4802         RETURN;
4803     }
4804
4805     if (nent) {
4806         mPUSHs(newSVpv(nent->n_name, 0));
4807         PUSHs(space_join_names_mortal(nent->n_aliases));
4808         mPUSHi(nent->n_addrtype);
4809         mPUSHi(nent->n_net);
4810     }
4811
4812     RETURN;
4813 #else
4814     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4815 #endif
4816 }
4817
4818 PP(pp_gprotoent)
4819 {
4820 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4821     dVAR; dSP;
4822     I32 which = PL_op->op_type;
4823     SV *sv;
4824 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4825     struct protoent *getprotobyname(Netdb_name_t);
4826     struct protoent *getprotobynumber(int);
4827     struct protoent *getprotoent(void);
4828 #endif
4829     struct protoent *pent;
4830
4831     if (which == OP_GPBYNAME) {
4832 #ifdef HAS_GETPROTOBYNAME
4833         const char* const name = POPpbytex;
4834         pent = PerlSock_getprotobyname(name);
4835 #else
4836         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4837 #endif
4838     }
4839     else if (which == OP_GPBYNUMBER) {
4840 #ifdef HAS_GETPROTOBYNUMBER
4841         const int number = POPi;
4842         pent = PerlSock_getprotobynumber(number);
4843 #else
4844         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4845 #endif
4846     }
4847     else
4848 #ifdef HAS_GETPROTOENT
4849         pent = PerlSock_getprotoent();
4850 #else
4851         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4852 #endif
4853
4854     EXTEND(SP, 3);
4855     if (GIMME != G_ARRAY) {
4856         PUSHs(sv = sv_newmortal());
4857         if (pent) {
4858             if (which == OP_GPBYNAME)
4859                 sv_setiv(sv, (IV)pent->p_proto);
4860             else
4861                 sv_setpv(sv, pent->p_name);
4862         }
4863         RETURN;
4864     }
4865
4866     if (pent) {
4867         mPUSHs(newSVpv(pent->p_name, 0));
4868         PUSHs(space_join_names_mortal(pent->p_aliases));
4869         mPUSHi(pent->p_proto);
4870     }
4871
4872     RETURN;
4873 #else
4874     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4875 #endif
4876 }
4877
4878 PP(pp_gservent)
4879 {
4880 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4881     dVAR; dSP;
4882     I32 which = PL_op->op_type;
4883     SV *sv;
4884 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4885     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4886     struct servent *getservbyport(int, Netdb_name_t);
4887     struct servent *getservent(void);
4888 #endif
4889     struct servent *sent;
4890
4891     if (which == OP_GSBYNAME) {
4892 #ifdef HAS_GETSERVBYNAME
4893         const char * const proto = POPpbytex;
4894         const char * const name = POPpbytex;
4895         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4896 #else
4897         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4898 #endif
4899     }
4900     else if (which == OP_GSBYPORT) {
4901 #ifdef HAS_GETSERVBYPORT
4902         const char * const proto = POPpbytex;
4903         unsigned short port = (unsigned short)POPu;
4904         port = PerlSock_htons(port);
4905         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4906 #else
4907         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4908 #endif
4909     }
4910     else
4911 #ifdef HAS_GETSERVENT
4912         sent = PerlSock_getservent();
4913 #else
4914         DIE(aTHX_ PL_no_sock_func, "getservent");
4915 #endif
4916
4917     EXTEND(SP, 4);
4918     if (GIMME != G_ARRAY) {
4919         PUSHs(sv = sv_newmortal());
4920         if (sent) {
4921             if (which == OP_GSBYNAME) {
4922                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4923             }
4924             else
4925                 sv_setpv(sv, sent->s_name);
4926         }
4927         RETURN;
4928     }
4929
4930     if (sent) {
4931         mPUSHs(newSVpv(sent->s_name, 0));
4932         PUSHs(space_join_names_mortal(sent->s_aliases));
4933         mPUSHi(PerlSock_ntohs(sent->s_port));
4934         mPUSHs(newSVpv(sent->s_proto, 0));
4935     }
4936
4937     RETURN;
4938 #else
4939     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4940 #endif
4941 }
4942
4943 PP(pp_shostent)
4944 {
4945     dVAR; dSP;
4946     const int stayopen = TOPi;
4947     switch(PL_op->op_type) {
4948     case OP_SHOSTENT:
4949 #ifdef HAS_SETHOSTENT
4950         PerlSock_sethostent(stayopen);
4951 #else
4952         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4953 #endif
4954         break;
4955 #ifdef HAS_SETNETENT
4956     case OP_SNETENT:
4957         PerlSock_setnetent(stayopen);
4958 #else
4959         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4960 #endif
4961         break;
4962     case OP_SPROTOENT:
4963 #ifdef HAS_SETPROTOENT
4964         PerlSock_setprotoent(stayopen);
4965 #else
4966         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4967 #endif
4968         break;
4969     case OP_SSERVENT:
4970 #ifdef HAS_SETSERVENT
4971         PerlSock_setservent(stayopen);
4972 #else
4973         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4974 #endif
4975         break;
4976     }
4977     RETSETYES;
4978 }
4979
4980 PP(pp_ehostent)
4981 {
4982     dVAR; dSP;
4983     switch(PL_op->op_type) {
4984     case OP_EHOSTENT:
4985 #ifdef HAS_ENDHOSTENT
4986         PerlSock_endhostent();
4987 #else
4988         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4989 #endif
4990         break;
4991     case OP_ENETENT:
4992 #ifdef HAS_ENDNETENT
4993         PerlSock_endnetent();
4994 #else
4995         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4996 #endif
4997         break;
4998     case OP_EPROTOENT:
4999 #ifdef HAS_ENDPROTOENT
5000         PerlSock_endprotoent();
5001 #else
5002         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5003 #endif
5004         break;
5005     case OP_ESERVENT:
5006 #ifdef HAS_ENDSERVENT
5007         PerlSock_endservent();
5008 #else
5009         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5010 #endif
5011         break;
5012     case OP_SGRENT:
5013 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5014         setgrent();
5015 #else
5016         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5017 #endif
5018         break;
5019     case OP_EGRENT:
5020 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5021         endgrent();
5022 #else
5023         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5024 #endif
5025         brea