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