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