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