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