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