perlhacktips: Add character set portability tip
[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 #include "reentr.h"
183
184 #ifdef __Lynx__
185 /* Missing protos on LynxOS */
186 void sethostent(int);
187 void endhostent(void);
188 void setnetent(int);
189 void endnetent(void);
190 void setprotoent(int);
191 void endprotoent(void);
192 void setservent(int);
193 void endservent(void);
194 #endif
195
196 #undef PERL_EFF_ACCESS  /* EFFective uid/gid ACCESS */
197
198 /* F_OK unused: if stat() cannot find it... */
199
200 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
201     /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
202 #   define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
203 #endif
204
205 #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
206 #   ifdef I_SYS_SECURITY
207 #       include <sys/security.h>
208 #   endif
209 #   ifdef ACC_SELF
210         /* HP SecureWare */
211 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
212 #   else
213         /* SCO */
214 #       define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
215 #   endif
216 #endif
217
218 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
219     /* AIX */
220 #   define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
221 #endif
222
223
224 #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS)    \
225     && (defined(HAS_SETREUID) || defined(HAS_SETRESUID)         \
226         || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
227 /* The Hard Way. */
228 STATIC int
229 S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
230 {
231     const Uid_t ruid = getuid();
232     const Uid_t euid = geteuid();
233     const Gid_t rgid = getgid();
234     const Gid_t egid = getegid();
235     int res;
236
237 #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
238     Perl_croak(aTHX_ "switching effective uid is not implemented");
239 #else
240 #ifdef HAS_SETREUID
241     if (setreuid(euid, ruid))
242 #else
243 #ifdef HAS_SETRESUID
244     if (setresuid(euid, ruid, (Uid_t)-1))
245 #endif
246 #endif
247         /* diag_listed_as: entering effective %s failed */
248         Perl_croak(aTHX_ "entering effective uid failed");
249 #endif
250
251 #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
252     Perl_croak(aTHX_ "switching effective gid is not implemented");
253 #else
254 #ifdef HAS_SETREGID
255     if (setregid(egid, rgid))
256 #else
257 #ifdef HAS_SETRESGID
258     if (setresgid(egid, rgid, (Gid_t)-1))
259 #endif
260 #endif
261         /* diag_listed_as: entering effective %s failed */
262         Perl_croak(aTHX_ "entering effective gid failed");
263 #endif
264
265     res = access(path, mode);
266
267 #ifdef HAS_SETREUID
268     if (setreuid(ruid, euid))
269 #else
270 #ifdef HAS_SETRESUID
271     if (setresuid(ruid, euid, (Uid_t)-1))
272 #endif
273 #endif
274         /* diag_listed_as: leaving effective %s failed */
275         Perl_croak(aTHX_ "leaving effective uid failed");
276
277 #ifdef HAS_SETREGID
278     if (setregid(rgid, egid))
279 #else
280 #ifdef HAS_SETRESGID
281     if (setresgid(rgid, egid, (Gid_t)-1))
282 #endif
283 #endif
284         /* diag_listed_as: leaving effective %s failed */
285         Perl_croak(aTHX_ "leaving effective gid failed");
286
287     return res;
288 }
289 #   define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
290 #endif
291
292 PP(pp_backtick)
293 {
294     dSP; dTARGET;
295     PerlIO *fp;
296     const char * const tmps = POPpconstx;
297     const I32 gimme = GIMME_V;
298     const char *mode = "r";
299
300     TAINT_PROPER("``");
301     if (PL_op->op_private & OPpOPEN_IN_RAW)
302         mode = "rb";
303     else if (PL_op->op_private & OPpOPEN_IN_CRLF)
304         mode = "rt";
305     fp = PerlProc_popen(tmps, mode);
306     if (fp) {
307         const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
308         if (type && *type)
309             PerlIO_apply_layers(aTHX_ fp,mode,type);
310
311         if (gimme == G_VOID) {
312             char tmpbuf[256];
313             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
314                 NOOP;
315         }
316         else if (gimme == G_SCALAR) {
317             ENTER_with_name("backtick");
318             SAVESPTR(PL_rs);
319             PL_rs = &PL_sv_undef;
320             sv_setpvs(TARG, "");        /* note that this preserves previous buffer */
321             while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
322                 NOOP;
323             LEAVE_with_name("backtick");
324             XPUSHs(TARG);
325             SvTAINTED_on(TARG);
326         }
327         else {
328             for (;;) {
329                 SV * const sv = newSV(79);
330                 if (sv_gets(sv, fp, 0) == NULL) {
331                     SvREFCNT_dec(sv);
332                     break;
333                 }
334                 mXPUSHs(sv);
335                 if (SvLEN(sv) - SvCUR(sv) > 20) {
336                     SvPV_shrink_to_cur(sv);
337                 }
338                 SvTAINTED_on(sv);
339             }
340         }
341         STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
342         TAINT;          /* "I believe that this is not gratuitous!" */
343     }
344     else {
345         STATUS_NATIVE_CHILD_SET(-1);
346         if (gimme == G_SCALAR)
347             RETPUSHUNDEF;
348     }
349
350     RETURN;
351 }
352
353 PP(pp_glob)
354 {
355     OP *result;
356     dSP;
357     GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
358
359     PUTBACK;
360
361     /* make a copy of the pattern if it is gmagical, to ensure that magic
362      * is called once and only once */
363     if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
364
365     tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
366
367     if (PL_op->op_flags & OPf_SPECIAL) {
368         /* call Perl-level glob function instead. Stack args are:
369          * MARK, wildcard
370          * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
371          * */
372         return NORMAL;
373     }
374     if (PL_globhook) {
375         PL_globhook(aTHX);
376         return NORMAL;
377     }
378
379     /* Note that we only ever get here if File::Glob fails to load
380      * without at the same time croaking, for some reason, or if
381      * perl was built with PERL_EXTERNAL_GLOB */
382
383     ENTER_with_name("glob");
384
385 #ifndef VMS
386     if (TAINTING_get) {
387         /*
388          * The external globbing program may use things we can't control,
389          * so for security reasons we must assume the worst.
390          */
391         TAINT;
392         taint_proper(PL_no_security, "glob");
393     }
394 #endif /* !VMS */
395
396     SAVESPTR(PL_last_in_gv);    /* We don't want this to be permanent. */
397     PL_last_in_gv = gv;
398
399     SAVESPTR(PL_rs);            /* This is not permanent, either. */
400     PL_rs = newSVpvs_flags("\000", SVs_TEMP);
401 #ifndef DOSISH
402 #ifndef CSH
403     *SvPVX(PL_rs) = '\n';
404 #endif  /* !CSH */
405 #endif  /* !DOSISH */
406
407     result = do_readline();
408     LEAVE_with_name("glob");
409     return result;
410 }
411
412 PP(pp_rcatline)
413 {
414     PL_last_in_gv = cGVOP_gv;
415     return do_readline();
416 }
417
418 PP(pp_warn)
419 {
420     dSP; dMARK;
421     SV *exsv;
422     STRLEN len;
423     if (SP - MARK > 1) {
424         dTARGET;
425         do_join(TARG, &PL_sv_no, MARK, SP);
426         exsv = TARG;
427         SP = MARK + 1;
428     }
429     else if (SP == MARK) {
430         exsv = &PL_sv_no;
431         EXTEND(SP, 1);
432         SP = MARK + 1;
433     }
434     else {
435         exsv = TOPs;
436         if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
437     }
438
439     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
440         /* well-formed exception supplied */
441     }
442     else {
443       SV * const errsv = ERRSV;
444       SvGETMAGIC(errsv);
445       if (SvROK(errsv)) {
446         if (SvGMAGICAL(errsv)) {
447             exsv = sv_newmortal();
448             sv_setsv_nomg(exsv, errsv);
449         }
450         else exsv = errsv;
451       }
452       else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
453         exsv = sv_newmortal();
454         sv_setsv_nomg(exsv, errsv);
455         sv_catpvs(exsv, "\t...caught");
456       }
457       else {
458         exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
459       }
460     }
461     if (SvROK(exsv) && !PL_warnhook)
462          Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
463     else warn_sv(exsv);
464     RETSETYES;
465 }
466
467 PP(pp_die)
468 {
469     dSP; dMARK;
470     SV *exsv;
471     STRLEN len;
472 #ifdef VMS
473     VMSISH_HUSHED  =
474         VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
475 #endif
476     if (SP - MARK != 1) {
477         dTARGET;
478         do_join(TARG, &PL_sv_no, MARK, SP);
479         exsv = TARG;
480         SP = MARK + 1;
481     }
482     else {
483         exsv = TOPs;
484     }
485
486     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
487         /* well-formed exception supplied */
488     }
489     else {
490         SV * const errsv = ERRSV;
491         SvGETMAGIC(errsv);
492         if (SvROK(errsv)) {
493             exsv = errsv;
494             if (sv_isobject(exsv)) {
495                 HV * const stash = SvSTASH(SvRV(exsv));
496                 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
497                 if (gv) {
498                     SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
499                     SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
500                     EXTEND(SP, 3);
501                     PUSHMARK(SP);
502                     PUSHs(exsv);
503                     PUSHs(file);
504                     PUSHs(line);
505                     PUTBACK;
506                     call_sv(MUTABLE_SV(GvCV(gv)),
507                             G_SCALAR|G_EVAL|G_KEEPERR);
508                     exsv = sv_mortalcopy(*PL_stack_sp--);
509                 }
510             }
511         }
512         else if (SvPOK(errsv) && SvCUR(errsv)) {
513             exsv = sv_mortalcopy(errsv);
514             sv_catpvs(exsv, "\t...propagated");
515         }
516         else {
517             exsv = newSVpvs_flags("Died", SVs_TEMP);
518         }
519     }
520     die_sv(exsv);
521     NOT_REACHED; /* NOTREACHED */
522     return NULL; /* avoid missing return from non-void function warning */
523 }
524
525 /* I/O. */
526
527 OP *
528 Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
529                  const MAGIC *const mg, const U32 flags, U32 argc, ...)
530 {
531     SV **orig_sp = sp;
532     I32 ret_args;
533
534     PERL_ARGS_ASSERT_TIED_METHOD;
535
536     /* Ensure that our flag bits do not overlap.  */
537     STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
538     STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
539     STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0);
540
541     PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
542     PUSHSTACKi(PERLSI_MAGIC);
543     EXTEND(SP, argc+1); /* object + args */
544     PUSHMARK(sp);
545     PUSHs(SvTIED_obj(sv, mg));
546     if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
547         Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
548         sp += argc;
549     }
550     else if (argc) {
551         const U32 mortalize_not_needed
552             = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
553         va_list args;
554         va_start(args, argc);
555         do {
556             SV *const arg = va_arg(args, SV *);
557             if(mortalize_not_needed)
558                 PUSHs(arg);
559             else
560                 mPUSHs(arg);
561         } while (--argc);
562         va_end(args);
563     }
564
565     PUTBACK;
566     ENTER_with_name("call_tied_method");
567     if (flags & TIED_METHOD_SAY) {
568         /* local $\ = "\n" */
569         SAVEGENERICSV(PL_ors_sv);
570         PL_ors_sv = newSVpvs("\n");
571     }
572     ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
573     SPAGAIN;
574     orig_sp = sp;
575     POPSTACK;
576     SPAGAIN;
577     if (ret_args) { /* copy results back to original stack */
578         EXTEND(sp, ret_args);
579         Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
580         sp += ret_args;
581         PUTBACK;
582     }
583     LEAVE_with_name("call_tied_method");
584     return NORMAL;
585 }
586
587 #define tied_method0(a,b,c,d)           \
588     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0)
589 #define tied_method1(a,b,c,d,e)         \
590     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e)
591 #define tied_method2(a,b,c,d,e,f)       \
592     Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f)
593
594 PP(pp_open)
595 {
596     dSP;
597     dMARK; dORIGMARK;
598     dTARGET;
599     SV *sv;
600     IO *io;
601     const char *tmps;
602     STRLEN len;
603     bool  ok;
604
605     GV * const gv = MUTABLE_GV(*++MARK);
606
607     if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
608         DIE(aTHX_ PL_no_usym, "filehandle");
609
610     if ((io = GvIOp(gv))) {
611         const MAGIC *mg;
612         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
613
614         if (IoDIRP(io))
615             Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
616                              "Opening dirhandle %"HEKf" also as a file",
617                              HEKfARG(GvENAME_HEK(gv)));
618
619         mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
620         if (mg) {
621             /* Method's args are same as ours ... */
622             /* ... except handle is replaced by the object */
623             return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
624                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
625                                     sp - mark);
626         }
627     }
628
629     if (MARK < SP) {
630         sv = *++MARK;
631     }
632     else {
633         sv = GvSVn(gv);
634     }
635
636     tmps = SvPV_const(sv, len);
637     ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK));
638     SP = ORIGMARK;
639     if (ok)
640         PUSHi( (I32)PL_forkprocess );
641     else if (PL_forkprocess == 0)               /* we are a new child */
642         PUSHi(0);
643     else
644         RETPUSHUNDEF;
645     RETURN;
646 }
647
648 PP(pp_close)
649 {
650     dSP;
651     GV * const gv =
652         MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
653
654     if (MAXARG == 0)
655         EXTEND(SP, 1);
656
657     if (gv) {
658         IO * const io = GvIO(gv);
659         if (io) {
660             const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
661             if (mg) {
662                 return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
663             }
664         }
665     }
666     PUSHs(boolSV(do_close(gv, TRUE)));
667     RETURN;
668 }
669
670 PP(pp_pipe_op)
671 {
672 #ifdef HAS_PIPE
673     dSP;
674     IO *rstio;
675     IO *wstio;
676     int fd[2];
677
678     GV * const wgv = MUTABLE_GV(POPs);
679     GV * const rgv = MUTABLE_GV(POPs);
680
681     assert (isGV_with_GP(rgv));
682     assert (isGV_with_GP(wgv));
683     rstio = GvIOn(rgv);
684     if (IoIFP(rstio))
685         do_close(rgv, FALSE);
686
687     wstio = GvIOn(wgv);
688     if (IoIFP(wstio))
689         do_close(wgv, FALSE);
690
691     if (PerlProc_pipe(fd) < 0)
692         goto badexit;
693
694     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
695     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
696     IoOFP(rstio) = IoIFP(rstio);
697     IoIFP(wstio) = IoOFP(wstio);
698     IoTYPE(rstio) = IoTYPE_RDONLY;
699     IoTYPE(wstio) = IoTYPE_WRONLY;
700
701     if (!IoIFP(rstio) || !IoOFP(wstio)) {
702         if (IoIFP(rstio))
703             PerlIO_close(IoIFP(rstio));
704         else
705             PerlLIO_close(fd[0]);
706         if (IoOFP(wstio))
707             PerlIO_close(IoOFP(wstio));
708         else
709             PerlLIO_close(fd[1]);
710         goto badexit;
711     }
712 #if defined(HAS_FCNTL) && defined(F_SETFD)
713     /* ensure close-on-exec */
714     if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
715         (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
716         goto badexit;
717 #endif
718     RETPUSHYES;
719
720   badexit:
721     RETPUSHUNDEF;
722 #else
723     DIE(aTHX_ PL_no_func, "pipe");
724 #endif
725 }
726
727 PP(pp_fileno)
728 {
729     dSP; dTARGET;
730     GV *gv;
731     IO *io;
732     PerlIO *fp;
733     const MAGIC *mg;
734
735     if (MAXARG < 1)
736         RETPUSHUNDEF;
737     gv = MUTABLE_GV(POPs);
738     io = GvIO(gv);
739
740     if (io
741         && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
742     {
743         return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
744     }
745
746     if (io && IoDIRP(io)) {
747 #if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD)
748         PUSHi(my_dirfd(IoDIRP(io)));
749         RETURN;
750 #elif defined(ENOTSUP)
751         errno = ENOTSUP;        /* Operation not supported */
752         RETPUSHUNDEF;
753 #elif defined(EOPNOTSUPP)
754         errno = EOPNOTSUPP;     /* Operation not supported on socket */
755         RETPUSHUNDEF;
756 #else
757         errno = EINVAL;         /* Invalid argument */
758         RETPUSHUNDEF;
759 #endif
760     }
761
762     if (!io || !(fp = IoIFP(io))) {
763         /* Can't do this because people seem to do things like
764            defined(fileno($foo)) to check whether $foo is a valid fh.
765
766            report_evil_fh(gv);
767             */
768         RETPUSHUNDEF;
769     }
770
771     PUSHi(PerlIO_fileno(fp));
772     RETURN;
773 }
774
775 PP(pp_umask)
776 {
777     dSP;
778 #ifdef HAS_UMASK
779     dTARGET;
780     Mode_t anum;
781
782     if (MAXARG < 1 || (!TOPs && !POPs)) {
783         anum = PerlLIO_umask(022);
784         /* setting it to 022 between the two calls to umask avoids
785          * to have a window where the umask is set to 0 -- meaning
786          * that another thread could create world-writeable files. */
787         if (anum != 022)
788             (void)PerlLIO_umask(anum);
789     }
790     else
791         anum = PerlLIO_umask(POPi);
792     TAINT_PROPER("umask");
793     XPUSHi(anum);
794 #else
795     /* Only DIE if trying to restrict permissions on "user" (self).
796      * Otherwise it's harmless and more useful to just return undef
797      * since 'group' and 'other' concepts probably don't exist here. */
798     if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
799         DIE(aTHX_ "umask not implemented");
800     XPUSHs(&PL_sv_undef);
801 #endif
802     RETURN;
803 }
804
805 PP(pp_binmode)
806 {
807     dSP;
808     GV *gv;
809     IO *io;
810     PerlIO *fp;
811     SV *discp = NULL;
812
813     if (MAXARG < 1)
814         RETPUSHUNDEF;
815     if (MAXARG > 1) {
816         discp = POPs;
817     }
818
819     gv = MUTABLE_GV(POPs);
820     io = GvIO(gv);
821
822     if (io) {
823         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
824         if (mg) {
825             /* This takes advantage of the implementation of the varargs
826                function, which I don't think that the optimiser will be able to
827                figure out. Although, as it's a static function, in theory it
828                could.  */
829             return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
830                                     G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
831                                     discp ? 1 : 0, discp);
832         }
833     }
834
835     if (!io || !(fp = IoIFP(io))) {
836         report_evil_fh(gv);
837         SETERRNO(EBADF,RMS_IFI);
838         RETPUSHUNDEF;
839     }
840
841     PUTBACK;
842     {
843         STRLEN len = 0;
844         const char *d = NULL;
845         int mode;
846         if (discp)
847             d = SvPV_const(discp, len);
848         mode = mode_from_discipline(d, len);
849         if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
850             if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
851                 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
852                     SPAGAIN;
853                     RETPUSHUNDEF;
854                 }
855             }
856             SPAGAIN;
857             RETPUSHYES;
858         }
859         else {
860             SPAGAIN;
861             RETPUSHUNDEF;
862         }
863     }
864 }
865
866 PP(pp_tie)
867 {
868     dSP; dMARK;
869     HV* stash;
870     GV *gv = NULL;
871     SV *sv;
872     const I32 markoff = MARK - PL_stack_base;
873     const char *methname;
874     int how = PERL_MAGIC_tied;
875     U32 items;
876     SV *varsv = *++MARK;
877
878     switch(SvTYPE(varsv)) {
879         case SVt_PVHV:
880         {
881             HE *entry;
882             methname = "TIEHASH";
883             if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
884                 HvLAZYDEL_off(varsv);
885                 hv_free_ent((HV *)varsv, entry);
886             }
887             HvEITER_set(MUTABLE_HV(varsv), 0);
888             break;
889         }
890         case SVt_PVAV:
891             methname = "TIEARRAY";
892             if (!AvREAL(varsv)) {
893                 if (!AvREIFY(varsv))
894                     Perl_croak(aTHX_ "Cannot tie unreifiable array");
895                 av_clear((AV *)varsv);
896                 AvREIFY_off(varsv);
897                 AvREAL_on(varsv);
898             }
899             break;
900         case SVt_PVGV:
901         case SVt_PVLV:
902             if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
903                 methname = "TIEHANDLE";
904                 how = PERL_MAGIC_tiedscalar;
905                 /* For tied filehandles, we apply tiedscalar magic to the IO
906                    slot of the GP rather than the GV itself. AMS 20010812 */
907                 if (!GvIOp(varsv))
908                     GvIOp(varsv) = newIO();
909                 varsv = MUTABLE_SV(GvIOp(varsv));
910                 break;
911             }
912             if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
913                 vivify_defelem(varsv);
914                 varsv = LvTARG(varsv);
915             }
916             /* FALLTHROUGH */
917         default:
918             methname = "TIESCALAR";
919             how = PERL_MAGIC_tiedscalar;
920             break;
921     }
922     items = SP - MARK++;
923     if (sv_isobject(*MARK)) { /* Calls GET magic. */
924         ENTER_with_name("call_TIE");
925         PUSHSTACKi(PERLSI_MAGIC);
926         PUSHMARK(SP);
927         EXTEND(SP,(I32)items);
928         while (items--)
929             PUSHs(*MARK++);
930         PUTBACK;
931         call_method(methname, G_SCALAR);
932     }
933     else {
934         /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
935          * will attempt to invoke IO::File::TIEARRAY, with (best case) the
936          * wrong error message, and worse case, supreme action at a distance.
937          * (Sorry obfuscation writers. You're not going to be given this one.)
938          */
939        stash = gv_stashsv(*MARK, 0);
940        if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
941             DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
942                  methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
943         }
944         ENTER_with_name("call_TIE");
945         PUSHSTACKi(PERLSI_MAGIC);
946         PUSHMARK(SP);
947         EXTEND(SP,(I32)items);
948         while (items--)
949             PUSHs(*MARK++);
950         PUTBACK;
951         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
952     }
953     SPAGAIN;
954
955     sv = TOPs;
956     POPSTACK;
957     if (sv_isobject(sv)) {
958         sv_unmagic(varsv, how);
959         /* Croak if a self-tie on an aggregate is attempted. */
960         if (varsv == SvRV(sv) &&
961             (SvTYPE(varsv) == SVt_PVAV ||
962              SvTYPE(varsv) == SVt_PVHV))
963             Perl_croak(aTHX_
964                        "Self-ties of arrays and hashes are not supported");
965         sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
966     }
967     LEAVE_with_name("call_TIE");
968     SP = PL_stack_base + markoff;
969     PUSHs(sv);
970     RETURN;
971 }
972
973
974 /* also used for: pp_dbmclose() */
975
976 PP(pp_untie)
977 {
978     dSP;
979     MAGIC *mg;
980     SV *sv = POPs;
981     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
982                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
983
984     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
985         RETPUSHYES;
986
987     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
988         !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
989
990     if ((mg = SvTIED_mg(sv, how))) {
991         SV * const obj = SvRV(SvTIED_obj(sv, mg));
992         if (obj) {
993             GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
994             CV *cv;
995             if (gv && isGV(gv) && (cv = GvCV(gv))) {
996                PUSHMARK(SP);
997                PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
998                mXPUSHi(SvREFCNT(obj) - 1);
999                PUTBACK;
1000                ENTER_with_name("call_UNTIE");
1001                call_sv(MUTABLE_SV(cv), G_VOID);
1002                LEAVE_with_name("call_UNTIE");
1003                SPAGAIN;
1004             }
1005             else if (mg && SvREFCNT(obj) > 1) {
1006                 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
1007                                "untie attempted while %"UVuf" inner references still exist",
1008                                (UV)SvREFCNT(obj) - 1 ) ;
1009             }
1010         }
1011     }
1012     sv_unmagic(sv, how) ;
1013     RETPUSHYES;
1014 }
1015
1016 PP(pp_tied)
1017 {
1018     dSP;
1019     const MAGIC *mg;
1020     dTOPss;
1021     const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1022                 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1023
1024     if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
1025         goto ret_undef;
1026
1027     if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
1028         !(sv = defelem_target(sv, NULL))) goto ret_undef;
1029
1030     if ((mg = SvTIED_mg(sv, how))) {
1031         SETs(SvTIED_obj(sv, mg));
1032         return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */
1033     }
1034     ret_undef:
1035     SETs(&PL_sv_undef);
1036     return NORMAL;
1037 }
1038
1039 PP(pp_dbmopen)
1040 {
1041     dSP;
1042     dPOPPOPssrl;
1043     HV* stash;
1044     GV *gv = NULL;
1045
1046     HV * const hv = MUTABLE_HV(POPs);
1047     SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1048     stash = gv_stashsv(sv, 0);
1049     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
1050         PUTBACK;
1051         require_pv("AnyDBM_File.pm");
1052         SPAGAIN;
1053         if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
1054             DIE(aTHX_ "No dbm on this machine");
1055     }
1056
1057     ENTER;
1058     PUSHMARK(SP);
1059
1060     EXTEND(SP, 5);
1061     PUSHs(sv);
1062     PUSHs(left);
1063     if (SvIV(right))
1064         mPUSHu(O_RDWR|O_CREAT);
1065     else
1066     {
1067         mPUSHu(O_RDWR);
1068         if (!SvOK(right)) right = &PL_sv_no;
1069     }
1070     PUSHs(right);
1071     PUTBACK;
1072     call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1073     SPAGAIN;
1074
1075     if (!sv_isobject(TOPs)) {
1076         SP--;
1077         PUSHMARK(SP);
1078         PUSHs(sv);
1079         PUSHs(left);
1080         mPUSHu(O_RDONLY);
1081         PUSHs(right);
1082         PUTBACK;
1083         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1084         SPAGAIN;
1085     }
1086
1087     if (sv_isobject(TOPs)) {
1088         sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1089         sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1090     }
1091     LEAVE;
1092     RETURN;
1093 }
1094
1095 PP(pp_sselect)
1096 {
1097 #ifdef HAS_SELECT
1098     dSP; dTARGET;
1099     I32 i;
1100     I32 j;
1101     char *s;
1102     SV *sv;
1103     NV value;
1104     I32 maxlen = 0;
1105     I32 nfound;
1106     struct timeval timebuf;
1107     struct timeval *tbuf = &timebuf;
1108     I32 growsize;
1109     char *fd_sets[4];
1110 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1111         I32 masksize;
1112         I32 offset;
1113         I32 k;
1114
1115 #   if BYTEORDER & 0xf0000
1116 #       define ORDERBYTE (0x88888888 - BYTEORDER)
1117 #   else
1118 #       define ORDERBYTE (0x4444 - BYTEORDER)
1119 #   endif
1120
1121 #endif
1122
1123     SP -= 4;
1124     for (i = 1; i <= 3; i++) {
1125         SV * const sv = SP[i];
1126         SvGETMAGIC(sv);
1127         if (!SvOK(sv))
1128             continue;
1129         if (SvREADONLY(sv)) {
1130             if (!(SvPOK(sv) && SvCUR(sv) == 0))
1131                 Perl_croak_no_modify();
1132         }
1133         else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1134         if (!SvPOK(sv)) {
1135             if (!SvPOKp(sv))
1136                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1137                                     "Non-string passed as bitmask");
1138             SvPV_force_nomg_nolen(sv);  /* force string conversion */
1139         }
1140         j = SvCUR(sv);
1141         if (maxlen < j)
1142             maxlen = j;
1143     }
1144
1145 /* little endians can use vecs directly */
1146 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1147 #  ifdef NFDBITS
1148
1149 #    ifndef NBBY
1150 #     define NBBY 8
1151 #    endif
1152
1153     masksize = NFDBITS / NBBY;
1154 #  else
1155     masksize = sizeof(long);    /* documented int, everyone seems to use long */
1156 #  endif
1157     Zero(&fd_sets[0], 4, char*);
1158 #endif
1159
1160 #  if SELECT_MIN_BITS == 1
1161     growsize = sizeof(fd_set);
1162 #  else
1163 #   if defined(__GLIBC__) && defined(__FD_SETSIZE)
1164 #      undef SELECT_MIN_BITS
1165 #      define SELECT_MIN_BITS __FD_SETSIZE
1166 #   endif
1167     /* If SELECT_MIN_BITS is greater than one we most probably will want
1168      * to align the sizes with SELECT_MIN_BITS/8 because for example
1169      * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1170      * UNIX, Solaris, Darwin) the smallest quantum select() operates
1171      * on (sets/tests/clears bits) is 32 bits.  */
1172     growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1173 #  endif
1174
1175     sv = SP[4];
1176     SvGETMAGIC(sv);
1177     if (SvOK(sv)) {
1178         value = SvNV_nomg(sv);
1179         if (value < 0.0)
1180             value = 0.0;
1181         timebuf.tv_sec = (long)value;
1182         value -= (NV)timebuf.tv_sec;
1183         timebuf.tv_usec = (long)(value * 1000000.0);
1184     }
1185     else
1186         tbuf = NULL;
1187
1188     for (i = 1; i <= 3; i++) {
1189         sv = SP[i];
1190         if (!SvOK(sv) || SvCUR(sv) == 0) {
1191             fd_sets[i] = 0;
1192             continue;
1193         }
1194         assert(SvPOK(sv));
1195         j = SvLEN(sv);
1196         if (j < growsize) {
1197             Sv_Grow(sv, growsize);
1198         }
1199         j = SvCUR(sv);
1200         s = SvPVX(sv) + j;
1201         while (++j <= growsize) {
1202             *s++ = '\0';
1203         }
1204
1205 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1206         s = SvPVX(sv);
1207         Newx(fd_sets[i], growsize, char);
1208         for (offset = 0; offset < growsize; offset += masksize) {
1209             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1210                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1211         }
1212 #else
1213         fd_sets[i] = SvPVX(sv);
1214 #endif
1215     }
1216
1217 #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1218     /* Can't make just the (void*) conditional because that would be
1219      * cpp #if within cpp macro, and not all compilers like that. */
1220     nfound = PerlSock_select(
1221         maxlen * 8,
1222         (Select_fd_set_t) fd_sets[1],
1223         (Select_fd_set_t) fd_sets[2],
1224         (Select_fd_set_t) fd_sets[3],
1225         (void*) tbuf); /* Workaround for compiler bug. */
1226 #else
1227     nfound = PerlSock_select(
1228         maxlen * 8,
1229         (Select_fd_set_t) fd_sets[1],
1230         (Select_fd_set_t) fd_sets[2],
1231         (Select_fd_set_t) fd_sets[3],
1232         tbuf);
1233 #endif
1234     for (i = 1; i <= 3; i++) {
1235         if (fd_sets[i]) {
1236             sv = SP[i];
1237 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1238             s = SvPVX(sv);
1239             for (offset = 0; offset < growsize; offset += masksize) {
1240                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1241                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
1242             }
1243             Safefree(fd_sets[i]);
1244 #endif
1245             SvSETMAGIC(sv);
1246         }
1247     }
1248
1249     PUSHi(nfound);
1250     if (GIMME_V == G_ARRAY && tbuf) {
1251         value = (NV)(timebuf.tv_sec) +
1252                 (NV)(timebuf.tv_usec) / 1000000.0;
1253         mPUSHn(value);
1254     }
1255     RETURN;
1256 #else
1257     DIE(aTHX_ "select not implemented");
1258 #endif
1259 }
1260
1261 /*
1262
1263 =head1 GV Functions
1264
1265 =for apidoc setdefout
1266
1267 Sets PL_defoutgv, the default file handle for output, to the passed in
1268 typeglob.  As PL_defoutgv "owns" a reference on its typeglob, the reference
1269 count of the passed in typeglob is increased by one, and the reference count
1270 of the typeglob that PL_defoutgv points to is decreased by one.
1271
1272 =cut
1273 */
1274
1275 void
1276 Perl_setdefout(pTHX_ GV *gv)
1277 {
1278     PERL_ARGS_ASSERT_SETDEFOUT;
1279     SvREFCNT_inc_simple_void_NN(gv);
1280     SvREFCNT_dec(PL_defoutgv);
1281     PL_defoutgv = gv;
1282 }
1283
1284 PP(pp_select)
1285 {
1286     dSP; dTARGET;
1287     HV *hv;
1288     GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1289     GV * egv = GvEGVx(PL_defoutgv);
1290     GV * const *gvp;
1291
1292     if (!egv)
1293         egv = PL_defoutgv;
1294     hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
1295     gvp = hv && HvENAME(hv)
1296                 ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1297                 : NULL;
1298     if (gvp && *gvp == egv) {
1299             gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1300             XPUSHTARG;
1301     }
1302     else {
1303             mXPUSHs(newRV(MUTABLE_SV(egv)));
1304     }
1305
1306     if (newdefout) {
1307         if (!GvIO(newdefout))
1308             gv_IOadd(newdefout);
1309         setdefout(newdefout);
1310     }
1311
1312     RETURN;
1313 }
1314
1315 PP(pp_getc)
1316 {
1317     dSP; dTARGET;
1318     GV * const gv =
1319         MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
1320     IO *const io = GvIO(gv);
1321
1322     if (MAXARG == 0)
1323         EXTEND(SP, 1);
1324
1325     if (io) {
1326         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1327         if (mg) {
1328             const U32 gimme = GIMME_V;
1329             Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1330             if (gimme == G_SCALAR) {
1331                 SPAGAIN;
1332                 SvSetMagicSV_nosteal(TARG, TOPs);
1333             }
1334             return NORMAL;
1335         }
1336     }
1337     if (!gv || do_eof(gv)) { /* make sure we have fp with something */
1338         if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1339             report_evil_fh(gv);
1340         SETERRNO(EBADF,RMS_IFI);
1341         RETPUSHUNDEF;
1342     }
1343     TAINT;
1344     sv_setpvs(TARG, " ");
1345     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1346     if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1347         /* Find out how many bytes the char needs */
1348         Size_t len = UTF8SKIP(SvPVX_const(TARG));
1349         if (len > 1) {
1350             SvGROW(TARG,len+1);
1351             len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1352             SvCUR_set(TARG,1+len);
1353         }
1354         SvUTF8_on(TARG);
1355     }
1356     else SvUTF8_off(TARG);
1357     PUSHTARG;
1358     RETURN;
1359 }
1360
1361 STATIC OP *
1362 S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1363 {
1364     PERL_CONTEXT *cx;
1365     const I32 gimme = GIMME_V;
1366
1367     PERL_ARGS_ASSERT_DOFORM;
1368
1369     if (CvCLONE(cv))
1370         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1371
1372     ENTER;
1373     SAVETMPS;
1374
1375     PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1376     PUSHFORMAT(cx, retop);
1377     if (CvDEPTH(cv) >= 2) {
1378         PERL_STACK_OVERFLOW_CHECK();
1379         pad_push(CvPADLIST(cv), CvDEPTH(cv));
1380     }
1381     SAVECOMPPAD();
1382     PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1383
1384     setdefout(gv);          /* locally select filehandle so $% et al work */
1385     return CvSTART(cv);
1386 }
1387
1388 PP(pp_enterwrite)
1389 {
1390     dSP;
1391     GV *gv;
1392     IO *io;
1393     GV *fgv;
1394     CV *cv = NULL;
1395     SV *tmpsv = NULL;
1396
1397     if (MAXARG == 0) {
1398         EXTEND(SP, 1);
1399         gv = PL_defoutgv;
1400     }
1401     else {
1402         gv = MUTABLE_GV(POPs);
1403         if (!gv)
1404             gv = PL_defoutgv;
1405     }
1406     io = GvIO(gv);
1407     if (!io) {
1408         RETPUSHNO;
1409     }
1410     if (IoFMT_GV(io))
1411         fgv = IoFMT_GV(io);
1412     else
1413         fgv = gv;
1414
1415     assert(fgv);
1416
1417     cv = GvFORM(fgv);
1418     if (!cv) {
1419         tmpsv = sv_newmortal();
1420         gv_efullname4(tmpsv, fgv, NULL, FALSE);
1421         DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1422     }
1423     IoFLAGS(io) &= ~IOf_DIDTOP;
1424     RETURNOP(doform(cv,gv,PL_op->op_next));
1425 }
1426
1427 PP(pp_leavewrite)
1428 {
1429     dSP;
1430     GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1431     IO * const io = GvIOp(gv);
1432     PerlIO *ofp;
1433     PerlIO *fp;
1434     SV **newsp;
1435     I32 gimme;
1436     PERL_CONTEXT *cx;
1437     OP *retop;
1438
1439     if (!io || !(ofp = IoOFP(io)))
1440         goto forget_top;
1441
1442     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1443           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1444
1445     if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1446         PL_formtarget != PL_toptarget)
1447     {
1448         GV *fgv;
1449         CV *cv;
1450         if (!IoTOP_GV(io)) {
1451             GV *topgv;
1452
1453             if (!IoTOP_NAME(io)) {
1454                 SV *topname;
1455                 if (!IoFMT_NAME(io))
1456                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1457                 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1458                                         HEKfARG(GvNAME_HEK(gv))));
1459                 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1460                 if ((topgv && GvFORM(topgv)) ||
1461                   !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1462                     IoTOP_NAME(io) = savesvpv(topname);
1463                 else
1464                     IoTOP_NAME(io) = savepvs("top");
1465             }
1466             topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1467             if (!topgv || !GvFORM(topgv)) {
1468                 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1469                 goto forget_top;
1470             }
1471             IoTOP_GV(io) = topgv;
1472         }
1473         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1474             I32 lines = IoLINES_LEFT(io);
1475             const char *s = SvPVX_const(PL_formtarget);
1476             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1477                 goto forget_top;
1478             while (lines-- > 0) {
1479                 s = strchr(s, '\n');
1480                 if (!s)
1481                     break;
1482                 s++;
1483             }
1484             if (s) {
1485                 const STRLEN save = SvCUR(PL_formtarget);
1486                 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1487                 do_print(PL_formtarget, ofp);
1488                 SvCUR_set(PL_formtarget, save);
1489                 sv_chop(PL_formtarget, s);
1490                 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1491             }
1492         }
1493         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1494             do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1495         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1496         IoPAGE(io)++;
1497         PL_formtarget = PL_toptarget;
1498         IoFLAGS(io) |= IOf_DIDTOP;
1499         fgv = IoTOP_GV(io);
1500         assert(fgv); /* IoTOP_GV(io) should have been set above */
1501         cv = GvFORM(fgv);
1502         if (!cv) {
1503             SV * const sv = sv_newmortal();
1504             gv_efullname4(sv, fgv, NULL, FALSE);
1505             DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1506         }
1507         return doform(cv, gv, PL_op);
1508     }
1509
1510   forget_top:
1511     POPBLOCK(cx,PL_curpm);
1512     retop = cx->blk_sub.retop;
1513     POPFORMAT(cx);
1514     SP = newsp; /* ignore retval of formline */
1515     LEAVE;
1516
1517     if (!io || !(fp = IoOFP(io))) {
1518         if (io && IoIFP(io))
1519             report_wrongway_fh(gv, '<');
1520         else
1521             report_evil_fh(gv);
1522         PUSHs(&PL_sv_no);
1523     }
1524     else {
1525         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1526             Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1527         }
1528         if (!do_print(PL_formtarget, fp))
1529             PUSHs(&PL_sv_no);
1530         else {
1531             FmLINES(PL_formtarget) = 0;
1532             SvCUR_set(PL_formtarget, 0);
1533             *SvEND(PL_formtarget) = '\0';
1534             if (IoFLAGS(io) & IOf_FLUSH)
1535                 (void)PerlIO_flush(fp);
1536             PUSHs(&PL_sv_yes);
1537         }
1538     }
1539     PL_formtarget = PL_bodytarget;
1540     PERL_UNUSED_VAR(gimme);
1541     RETURNOP(retop);
1542 }
1543
1544 PP(pp_prtf)
1545 {
1546     dSP; dMARK; dORIGMARK;
1547     PerlIO *fp;
1548
1549     GV * const gv
1550         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1551     IO *const io = GvIO(gv);
1552
1553     /* Treat empty list as "" */
1554     if (MARK == SP) XPUSHs(&PL_sv_no);
1555
1556     if (io) {
1557         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1558         if (mg) {
1559             if (MARK == ORIGMARK) {
1560                 MEXTEND(SP, 1);
1561                 ++MARK;
1562                 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1563                 ++SP;
1564             }
1565             return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1566                                     mg,
1567                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1568                                     sp - mark);
1569         }
1570     }
1571
1572     if (!io) {
1573         report_evil_fh(gv);
1574         SETERRNO(EBADF,RMS_IFI);
1575         goto just_say_no;
1576     }
1577     else if (!(fp = IoOFP(io))) {
1578         if (IoIFP(io))
1579             report_wrongway_fh(gv, '<');
1580         else if (ckWARN(WARN_CLOSED))
1581             report_evil_fh(gv);
1582         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1583         goto just_say_no;
1584     }
1585     else {
1586         SV *sv = sv_newmortal();
1587         do_sprintf(sv, SP - MARK, MARK + 1);
1588         if (!do_print(sv, fp))
1589             goto just_say_no;
1590
1591         if (IoFLAGS(io) & IOf_FLUSH)
1592             if (PerlIO_flush(fp) == EOF)
1593                 goto just_say_no;
1594     }
1595     SP = ORIGMARK;
1596     PUSHs(&PL_sv_yes);
1597     RETURN;
1598
1599   just_say_no:
1600     SP = ORIGMARK;
1601     PUSHs(&PL_sv_undef);
1602     RETURN;
1603 }
1604
1605 PP(pp_sysopen)
1606 {
1607     dSP;
1608     const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1609     const int mode = POPi;
1610     SV * const sv = POPs;
1611     GV * const gv = MUTABLE_GV(POPs);
1612     STRLEN len;
1613
1614     /* Need TIEHANDLE method ? */
1615     const char * const tmps = SvPV_const(sv, len);
1616     if (do_open_raw(gv, tmps, len, mode, perm)) {
1617         IoLINES(GvIOp(gv)) = 0;
1618         PUSHs(&PL_sv_yes);
1619     }
1620     else {
1621         PUSHs(&PL_sv_undef);
1622     }
1623     RETURN;
1624 }
1625
1626
1627 /* also used for: pp_read() and pp_recv() (where supported) */
1628
1629 PP(pp_sysread)
1630 {
1631     dSP; dMARK; dORIGMARK; dTARGET;
1632     SSize_t offset;
1633     IO *io;
1634     char *buffer;
1635     STRLEN orig_size;
1636     SSize_t length;
1637     SSize_t count;
1638     SV *bufsv;
1639     STRLEN blen;
1640     int fp_utf8;
1641     int buffer_utf8;
1642     SV *read_target;
1643     Size_t got = 0;
1644     Size_t wanted;
1645     bool charstart = FALSE;
1646     STRLEN charskip = 0;
1647     STRLEN skip = 0;
1648     GV * const gv = MUTABLE_GV(*++MARK);
1649     int fd;
1650
1651     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1652         && gv && (io = GvIO(gv)) )
1653     {
1654         const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1655         if (mg) {
1656             return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1657                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1658                                     sp - mark);
1659         }
1660     }
1661
1662     if (!gv)
1663         goto say_undef;
1664     bufsv = *++MARK;
1665     if (! SvOK(bufsv))
1666         sv_setpvs(bufsv, "");
1667     length = SvIVx(*++MARK);
1668     if (length < 0)
1669         DIE(aTHX_ "Negative length");
1670     SETERRNO(0,0);
1671     if (MARK < SP)
1672         offset = SvIVx(*++MARK);
1673     else
1674         offset = 0;
1675     io = GvIO(gv);
1676     if (!io || !IoIFP(io)) {
1677         report_evil_fh(gv);
1678         SETERRNO(EBADF,RMS_IFI);
1679         goto say_undef;
1680     }
1681
1682     /* Note that fd can here validly be -1, don't check it yet. */
1683     fd = PerlIO_fileno(IoIFP(io));
1684
1685     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1686         buffer = SvPVutf8_force(bufsv, blen);
1687         /* UTF-8 may not have been set if they are all low bytes */
1688         SvUTF8_on(bufsv);
1689         buffer_utf8 = 0;
1690     }
1691     else {
1692         buffer = SvPV_force(bufsv, blen);
1693         buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1694     }
1695     if (DO_UTF8(bufsv)) {
1696         blen = sv_len_utf8_nomg(bufsv);
1697     }
1698
1699     charstart = TRUE;
1700     charskip  = 0;
1701     skip = 0;
1702     wanted = length;
1703
1704 #ifdef HAS_SOCKET
1705     if (PL_op->op_type == OP_RECV) {
1706         Sock_size_t bufsize;
1707         char namebuf[MAXPATHLEN];
1708         if (fd < 0) {
1709             SETERRNO(EBADF,SS_IVCHAN);
1710             RETPUSHUNDEF;
1711         }
1712 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1713         bufsize = sizeof (struct sockaddr_in);
1714 #else
1715         bufsize = sizeof namebuf;
1716 #endif
1717 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1718         if (bufsize >= 256)
1719             bufsize = 255;
1720 #endif
1721         buffer = SvGROW(bufsv, (STRLEN)(length+1));
1722         /* 'offset' means 'flags' here */
1723         count = PerlSock_recvfrom(fd, buffer, length, offset,
1724                                   (struct sockaddr *)namebuf, &bufsize);
1725         if (count < 0)
1726             RETPUSHUNDEF;
1727         /* MSG_TRUNC can give oversized count; quietly lose it */
1728         if (count > length)
1729             count = length;
1730         SvCUR_set(bufsv, count);
1731         *SvEND(bufsv) = '\0';
1732         (void)SvPOK_only(bufsv);
1733         if (fp_utf8)
1734             SvUTF8_on(bufsv);
1735         SvSETMAGIC(bufsv);
1736         /* This should not be marked tainted if the fp is marked clean */
1737         if (!(IoFLAGS(io) & IOf_UNTAINT))
1738             SvTAINTED_on(bufsv);
1739         SP = ORIGMARK;
1740 #if defined(__CYGWIN__)
1741         /* recvfrom() on cygwin doesn't set bufsize at all for
1742            connected sockets, leaving us with trash in the returned
1743            name, so use the same test as the Win32 code to check if it
1744            wasn't set, and set it [perl #118843] */
1745         if (bufsize == sizeof namebuf)
1746             bufsize = 0;
1747 #endif
1748         sv_setpvn(TARG, namebuf, bufsize);
1749         PUSHs(TARG);
1750         RETURN;
1751     }
1752 #endif
1753     if (offset < 0) {
1754         if (-offset > (SSize_t)blen)
1755             DIE(aTHX_ "Offset outside string");
1756         offset += blen;
1757     }
1758     if (DO_UTF8(bufsv)) {
1759         /* convert offset-as-chars to offset-as-bytes */
1760         if (offset >= (SSize_t)blen)
1761             offset += SvCUR(bufsv) - blen;
1762         else
1763             offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1764     }
1765
1766  more_bytes:
1767     /* Reestablish the fd in case it shifted from underneath us. */
1768     fd = PerlIO_fileno(IoIFP(io));
1769
1770     orig_size = SvCUR(bufsv);
1771     /* Allocating length + offset + 1 isn't perfect in the case of reading
1772        bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1773        unduly.
1774        (should be 2 * length + offset + 1, or possibly something longer if
1775        IN_ENCODING Is true) */
1776     buffer  = SvGROW(bufsv, (STRLEN)(length+offset+1));
1777     if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1778         Zero(buffer+orig_size, offset-orig_size, char);
1779     }
1780     buffer = buffer + offset;
1781     if (!buffer_utf8) {
1782         read_target = bufsv;
1783     } else {
1784         /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1785            concatenate it to the current buffer.  */
1786
1787         /* Truncate the existing buffer to the start of where we will be
1788            reading to:  */
1789         SvCUR_set(bufsv, offset);
1790
1791         read_target = sv_newmortal();
1792         SvUPGRADE(read_target, SVt_PV);
1793         buffer = SvGROW(read_target, (STRLEN)(length + 1));
1794     }
1795
1796     if (PL_op->op_type == OP_SYSREAD) {
1797 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1798         if (IoTYPE(io) == IoTYPE_SOCKET) {
1799             if (fd < 0) {
1800                 SETERRNO(EBADF,SS_IVCHAN);
1801                 count = -1;
1802             }
1803             else
1804                 count = PerlSock_recv(fd, buffer, length, 0);
1805         }
1806         else
1807 #endif
1808         {
1809             if (fd < 0) {
1810                 SETERRNO(EBADF,RMS_IFI);
1811                 count = -1;
1812             }
1813             else
1814                 count = PerlLIO_read(fd, buffer, length);
1815         }
1816     }
1817     else
1818     {
1819         count = PerlIO_read(IoIFP(io), buffer, length);
1820         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1821         if (count == 0 && PerlIO_error(IoIFP(io)))
1822             count = -1;
1823     }
1824     if (count < 0) {
1825         if (IoTYPE(io) == IoTYPE_WRONLY)
1826             report_wrongway_fh(gv, '>');
1827         goto say_undef;
1828     }
1829     SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1830     *SvEND(read_target) = '\0';
1831     (void)SvPOK_only(read_target);
1832     if (fp_utf8 && !IN_BYTES) {
1833         /* Look at utf8 we got back and count the characters */
1834         const char *bend = buffer + count;
1835         while (buffer < bend) {
1836             if (charstart) {
1837                 skip = UTF8SKIP(buffer);
1838                 charskip = 0;
1839             }
1840             if (buffer - charskip + skip > bend) {
1841                 /* partial character - try for rest of it */
1842                 length = skip - (bend-buffer);
1843                 offset = bend - SvPVX_const(bufsv);
1844                 charstart = FALSE;
1845                 charskip += count;
1846                 goto more_bytes;
1847             }
1848             else {
1849                 got++;
1850                 buffer += skip;
1851                 charstart = TRUE;
1852                 charskip  = 0;
1853             }
1854         }
1855         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1856            provided amount read (count) was what was requested (length)
1857          */
1858         if (got < wanted && count == length) {
1859             length = wanted - got;
1860             offset = bend - SvPVX_const(bufsv);
1861             goto more_bytes;
1862         }
1863         /* return value is character count */
1864         count = got;
1865         SvUTF8_on(bufsv);
1866     }
1867     else if (buffer_utf8) {
1868         /* Let svcatsv upgrade the bytes we read in to utf8.
1869            The buffer is a mortal so will be freed soon.  */
1870         sv_catsv_nomg(bufsv, read_target);
1871     }
1872     SvSETMAGIC(bufsv);
1873     /* This should not be marked tainted if the fp is marked clean */
1874     if (!(IoFLAGS(io) & IOf_UNTAINT))
1875         SvTAINTED_on(bufsv);
1876     SP = ORIGMARK;
1877     PUSHi(count);
1878     RETURN;
1879
1880   say_undef:
1881     SP = ORIGMARK;
1882     RETPUSHUNDEF;
1883 }
1884
1885
1886 /* also used for: pp_send() where defined */
1887
1888 PP(pp_syswrite)
1889 {
1890     dSP; dMARK; dORIGMARK; dTARGET;
1891     SV *bufsv;
1892     const char *buffer;
1893     SSize_t retval;
1894     STRLEN blen;
1895     STRLEN orig_blen_bytes;
1896     const int op_type = PL_op->op_type;
1897     bool doing_utf8;
1898     U8 *tmpbuf = NULL;
1899     GV *const gv = MUTABLE_GV(*++MARK);
1900     IO *const io = GvIO(gv);
1901     int fd;
1902
1903     if (op_type == OP_SYSWRITE && io) {
1904         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1905         if (mg) {
1906             if (MARK == SP - 1) {
1907                 SV *sv = *SP;
1908                 mXPUSHi(sv_len(sv));
1909                 PUTBACK;
1910             }
1911
1912             return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1913                                     G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1914                                     sp - mark);
1915         }
1916     }
1917     if (!gv)
1918         goto say_undef;
1919
1920     bufsv = *++MARK;
1921
1922     SETERRNO(0,0);
1923     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1924         retval = -1;
1925         if (io && IoIFP(io))
1926             report_wrongway_fh(gv, '<');
1927         else
1928             report_evil_fh(gv);
1929         SETERRNO(EBADF,RMS_IFI);
1930         goto say_undef;
1931     }
1932     fd = PerlIO_fileno(IoIFP(io));
1933     if (fd < 0) {
1934         SETERRNO(EBADF,SS_IVCHAN);
1935         retval = -1;
1936         goto say_undef;
1937     }
1938
1939     /* Do this first to trigger any overloading.  */
1940     buffer = SvPV_const(bufsv, blen);
1941     orig_blen_bytes = blen;
1942     doing_utf8 = DO_UTF8(bufsv);
1943
1944     if (PerlIO_isutf8(IoIFP(io))) {
1945         if (!SvUTF8(bufsv)) {
1946             /* We don't modify the original scalar.  */
1947             tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1948             buffer = (char *) tmpbuf;
1949             doing_utf8 = TRUE;
1950         }
1951     }
1952     else if (doing_utf8) {
1953         STRLEN tmplen = blen;
1954         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1955         if (!doing_utf8) {
1956             tmpbuf = result;
1957             buffer = (char *) tmpbuf;
1958             blen = tmplen;
1959         }
1960         else {
1961             assert((char *)result == buffer);
1962             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1963         }
1964     }
1965
1966 #ifdef HAS_SOCKET
1967     if (op_type == OP_SEND) {
1968         const int flags = SvIVx(*++MARK);
1969         if (SP > MARK) {
1970             STRLEN mlen;
1971             char * const sockbuf = SvPVx(*++MARK, mlen);
1972             retval = PerlSock_sendto(fd, buffer, blen,
1973                                      flags, (struct sockaddr *)sockbuf, mlen);
1974         }
1975         else {
1976             retval = PerlSock_send(fd, buffer, blen, flags);
1977         }
1978     }
1979     else
1980 #endif
1981     {
1982         Size_t length = 0; /* This length is in characters.  */
1983         STRLEN blen_chars;
1984         IV offset;
1985
1986         if (doing_utf8) {
1987             if (tmpbuf) {
1988                 /* The SV is bytes, and we've had to upgrade it.  */
1989                 blen_chars = orig_blen_bytes;
1990             } else {
1991                 /* The SV really is UTF-8.  */
1992                 /* Don't call sv_len_utf8 on a magical or overloaded
1993                    scalar, as we might get back a different result.  */
1994                 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
1995             }
1996         } else {
1997             blen_chars = blen;
1998         }
1999
2000         if (MARK >= SP) {
2001             length = blen_chars;
2002         } else {
2003 #if Size_t_size > IVSIZE
2004             length = (Size_t)SvNVx(*++MARK);
2005 #else
2006             length = (Size_t)SvIVx(*++MARK);
2007 #endif
2008             if ((SSize_t)length < 0) {
2009                 Safefree(tmpbuf);
2010                 DIE(aTHX_ "Negative length");
2011             }
2012         }
2013
2014         if (MARK < SP) {
2015             offset = SvIVx(*++MARK);
2016             if (offset < 0) {
2017                 if (-offset > (IV)blen_chars) {
2018                     Safefree(tmpbuf);
2019                     DIE(aTHX_ "Offset outside string");
2020                 }
2021                 offset += blen_chars;
2022             } else if (offset > (IV)blen_chars) {
2023                 Safefree(tmpbuf);
2024                 DIE(aTHX_ "Offset outside string");
2025             }
2026         } else
2027             offset = 0;
2028         if (length > blen_chars - offset)
2029             length = blen_chars - offset;
2030         if (doing_utf8) {
2031             /* Here we convert length from characters to bytes.  */
2032             if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2033                 /* Either we had to convert the SV, or the SV is magical, or
2034                    the SV has overloading, in which case we can't or mustn't
2035                    or mustn't call it again.  */
2036
2037                 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2038                 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2039             } else {
2040                 /* It's a real UTF-8 SV, and it's not going to change under
2041                    us.  Take advantage of any cache.  */
2042                 I32 start = offset;
2043                 I32 len_I32 = length;
2044
2045                 /* Convert the start and end character positions to bytes.
2046                    Remember that the second argument to sv_pos_u2b is relative
2047                    to the first.  */
2048                 sv_pos_u2b(bufsv, &start, &len_I32);
2049
2050                 buffer += start;
2051                 length = len_I32;
2052             }
2053         }
2054         else {
2055             buffer = buffer+offset;
2056         }
2057 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2058         if (IoTYPE(io) == IoTYPE_SOCKET) {
2059             retval = PerlSock_send(fd, buffer, length, 0);
2060         }
2061         else
2062 #endif
2063         {
2064             /* See the note at doio.c:do_print about filesize limits. --jhi */
2065             retval = PerlLIO_write(fd, buffer, length);
2066         }
2067     }
2068
2069     if (retval < 0)
2070         goto say_undef;
2071     SP = ORIGMARK;
2072     if (doing_utf8)
2073         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2074
2075     Safefree(tmpbuf);
2076 #if Size_t_size > IVSIZE
2077     PUSHn(retval);
2078 #else
2079     PUSHi(retval);
2080 #endif
2081     RETURN;
2082
2083   say_undef:
2084     Safefree(tmpbuf);
2085     SP = ORIGMARK;
2086     RETPUSHUNDEF;
2087 }
2088
2089 PP(pp_eof)
2090 {
2091     dSP;
2092     GV *gv;
2093     IO *io;
2094     const MAGIC *mg;
2095     /*
2096      * in Perl 5.12 and later, the additional parameter is a bitmask:
2097      * 0 = eof
2098      * 1 = eof(FH)
2099      * 2 = eof()  <- ARGV magic
2100      *
2101      * I'll rely on the compiler's trace flow analysis to decide whether to
2102      * actually assign this out here, or punt it into the only block where it is
2103      * used. Doing it out here is DRY on the condition logic.
2104      */
2105     unsigned int which;
2106
2107     if (MAXARG) {
2108         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2109         which = 1;
2110     }
2111     else {
2112         EXTEND(SP, 1);
2113
2114         if (PL_op->op_flags & OPf_SPECIAL) {
2115             gv = PL_last_in_gv = GvEGVx(PL_argvgv);     /* eof() - ARGV magic */
2116             which = 2;
2117         }
2118         else {
2119             gv = PL_last_in_gv;                 /* eof */
2120             which = 0;
2121         }
2122     }
2123
2124     if (!gv)
2125         RETPUSHNO;
2126
2127     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2128         return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2129     }
2130
2131     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {   /* eof() */
2132         if (io && !IoIFP(io)) {
2133             if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
2134                 SV ** svp;
2135                 IoLINES(io) = 0;
2136                 IoFLAGS(io) &= ~IOf_START;
2137                 do_open6(gv, "-", 1, NULL, NULL, 0);
2138                 svp = &GvSV(gv);
2139                 if (*svp) {
2140                     SV * sv = *svp;
2141                     sv_setpvs(sv, "-");
2142                     SvSETMAGIC(sv);
2143                 }
2144                 else
2145                     *svp = newSVpvs("-");
2146             }
2147             else if (!nextargv(gv, FALSE))
2148                 RETPUSHYES;
2149         }
2150     }
2151
2152     PUSHs(boolSV(do_eof(gv)));
2153     RETURN;
2154 }
2155
2156 PP(pp_tell)
2157 {
2158     dSP; dTARGET;
2159     GV *gv;
2160     IO *io;
2161
2162     if (MAXARG != 0 && (TOPs || POPs))
2163         PL_last_in_gv = MUTABLE_GV(POPs);
2164     else
2165         EXTEND(SP, 1);
2166     gv = PL_last_in_gv;
2167
2168     io = GvIO(gv);
2169     if (io) {
2170         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2171         if (mg) {
2172             return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2173         }
2174     }
2175     else if (!gv) {
2176         if (!errno)
2177             SETERRNO(EBADF,RMS_IFI);
2178         PUSHi(-1);
2179         RETURN;
2180     }
2181
2182 #if LSEEKSIZE > IVSIZE
2183     PUSHn( do_tell(gv) );
2184 #else
2185     PUSHi( do_tell(gv) );
2186 #endif
2187     RETURN;
2188 }
2189
2190
2191 /* also used for: pp_seek() */
2192
2193 PP(pp_sysseek)
2194 {
2195     dSP;
2196     const int whence = POPi;
2197 #if LSEEKSIZE > IVSIZE
2198     const Off_t offset = (Off_t)SvNVx(POPs);
2199 #else
2200     const Off_t offset = (Off_t)SvIVx(POPs);
2201 #endif
2202
2203     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2204     IO *const io = GvIO(gv);
2205
2206     if (io) {
2207         const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2208         if (mg) {
2209 #if LSEEKSIZE > IVSIZE
2210             SV *const offset_sv = newSVnv((NV) offset);
2211 #else
2212             SV *const offset_sv = newSViv(offset);
2213 #endif
2214
2215             return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2216                                 newSViv(whence));
2217         }
2218     }
2219
2220     if (PL_op->op_type == OP_SEEK)
2221         PUSHs(boolSV(do_seek(gv, offset, whence)));
2222     else {
2223         const Off_t sought = do_sysseek(gv, offset, whence);
2224         if (sought < 0)
2225             PUSHs(&PL_sv_undef);
2226         else {
2227             SV* const sv = sought ?
2228 #if LSEEKSIZE > IVSIZE
2229                 newSVnv((NV)sought)
2230 #else
2231                 newSViv(sought)
2232 #endif
2233                 : newSVpvn(zero_but_true, ZBTLEN);
2234             mPUSHs(sv);
2235         }
2236     }
2237     RETURN;
2238 }
2239
2240 PP(pp_truncate)
2241 {
2242     dSP;
2243     /* There seems to be no consensus on the length type of truncate()
2244      * and ftruncate(), both off_t and size_t have supporters. In
2245      * general one would think that when using large files, off_t is
2246      * at least as wide as size_t, so using an off_t should be okay. */
2247     /* XXX Configure probe for the length type of *truncate() needed XXX */
2248     Off_t len;
2249
2250 #if Off_t_size > IVSIZE
2251     len = (Off_t)POPn;
2252 #else
2253     len = (Off_t)POPi;
2254 #endif
2255     /* Checking for length < 0 is problematic as the type might or
2256      * might not be signed: if it is not, clever compilers will moan. */
2257     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2258     SETERRNO(0,0);
2259     {
2260         SV * const sv = POPs;
2261         int result = 1;
2262         GV *tmpgv;
2263         IO *io;
2264
2265         if (PL_op->op_flags & OPf_SPECIAL
2266                        ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2267                        : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
2268             io = GvIO(tmpgv);
2269             if (!io)
2270                 result = 0;
2271             else {
2272                 PerlIO *fp;
2273             do_ftruncate_io:
2274                 TAINT_PROPER("truncate");
2275                 if (!(fp = IoIFP(io))) {
2276                     result = 0;
2277                 }
2278                 else {
2279                     int fd = PerlIO_fileno(fp);
2280                     if (fd < 0) {
2281                         SETERRNO(EBADF,RMS_IFI);
2282                         result = 0;
2283                     } else {
2284                         PerlIO_flush(fp);
2285 #ifdef HAS_TRUNCATE
2286                         if (ftruncate(fd, len) < 0)
2287 #else
2288                         if (my_chsize(fd, len) < 0)
2289 #endif
2290                             result = 0;
2291                     }
2292                 }
2293             }
2294         }
2295         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2296                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2297                 goto do_ftruncate_io;
2298         }
2299         else {
2300             const char * const name = SvPV_nomg_const_nolen(sv);
2301             TAINT_PROPER("truncate");
2302 #ifdef HAS_TRUNCATE
2303             if (truncate(name, len) < 0)
2304                 result = 0;
2305 #else
2306             {
2307                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2308
2309                 if (tmpfd < 0) {
2310                     SETERRNO(EBADF,RMS_IFI);
2311                     result = 0;
2312                 } else {
2313                     if (my_chsize(tmpfd, len) < 0)
2314                         result = 0;
2315                     PerlLIO_close(tmpfd);
2316                 }
2317             }
2318 #endif
2319         }
2320
2321         if (result)
2322             RETPUSHYES;
2323         if (!errno)
2324             SETERRNO(EBADF,RMS_IFI);
2325         RETPUSHUNDEF;
2326     }
2327 }
2328
2329
2330 /* also used for: pp_fcntl() */
2331
2332 PP(pp_ioctl)
2333 {
2334     dSP; dTARGET;
2335     SV * const argsv = POPs;
2336     const unsigned int func = POPu;
2337     int optype;
2338     GV * const gv = MUTABLE_GV(POPs);
2339     IO * const io = GvIOn(gv);
2340     char *s;
2341     IV retval;
2342
2343     if (!IoIFP(io)) {
2344         report_evil_fh(gv);
2345         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2346         RETPUSHUNDEF;
2347     }
2348
2349     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2350         STRLEN len;
2351         STRLEN need;
2352         s = SvPV_force(argsv, len);
2353         need = IOCPARM_LEN(func);
2354         if (len < need) {
2355             s = Sv_Grow(argsv, need + 1);
2356             SvCUR_set(argsv, need);
2357         }
2358
2359         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2360     }
2361     else {
2362         retval = SvIV(argsv);
2363         s = INT2PTR(char*,retval);              /* ouch */
2364     }
2365
2366     optype = PL_op->op_type;
2367     TAINT_PROPER(PL_op_desc[optype]);
2368
2369     if (optype == OP_IOCTL)
2370 #ifdef HAS_IOCTL
2371         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2372 #else
2373         DIE(aTHX_ "ioctl is not implemented");
2374 #endif
2375     else
2376 #ifndef HAS_FCNTL
2377       DIE(aTHX_ "fcntl is not implemented");
2378 #else
2379 #if defined(OS2) && defined(__EMX__)
2380         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2381 #else
2382         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2383 #endif
2384 #endif
2385
2386 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2387     if (SvPOK(argsv)) {
2388         if (s[SvCUR(argsv)] != 17)
2389             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2390                 OP_NAME(PL_op));
2391         s[SvCUR(argsv)] = 0;            /* put our null back */
2392         SvSETMAGIC(argsv);              /* Assume it has changed */
2393     }
2394
2395     if (retval == -1)
2396         RETPUSHUNDEF;
2397     if (retval != 0) {
2398         PUSHi(retval);
2399     }
2400     else {
2401         PUSHp(zero_but_true, ZBTLEN);
2402     }
2403 #endif
2404     RETURN;
2405 }
2406
2407 PP(pp_flock)
2408 {
2409 #ifdef FLOCK
2410     dSP; dTARGET;
2411     I32 value;
2412     const int argtype = POPi;
2413     GV * const gv = MUTABLE_GV(POPs);
2414     IO *const io = GvIO(gv);
2415     PerlIO *const fp = io ? IoIFP(io) : NULL;
2416
2417     /* XXX Looks to me like io is always NULL at this point */
2418     if (fp) {
2419         (void)PerlIO_flush(fp);
2420         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2421     }
2422     else {
2423         report_evil_fh(gv);
2424         value = 0;
2425         SETERRNO(EBADF,RMS_IFI);
2426     }
2427     PUSHi(value);
2428     RETURN;
2429 #else
2430     DIE(aTHX_ PL_no_func, "flock");
2431 #endif
2432 }
2433
2434 /* Sockets. */
2435
2436 #ifdef HAS_SOCKET
2437
2438 PP(pp_socket)
2439 {
2440     dSP;
2441     const int protocol = POPi;
2442     const int type = POPi;
2443     const int domain = POPi;
2444     GV * const gv = MUTABLE_GV(POPs);
2445     IO * const io = GvIOn(gv);
2446     int fd;
2447
2448     if (IoIFP(io))
2449         do_close(gv, FALSE);
2450
2451     TAINT_PROPER("socket");
2452     fd = PerlSock_socket(domain, type, protocol);
2453     if (fd < 0) {
2454         SETERRNO(EBADF,RMS_IFI);
2455         RETPUSHUNDEF;
2456     }
2457     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2458     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2459     IoTYPE(io) = IoTYPE_SOCKET;
2460     if (!IoIFP(io) || !IoOFP(io)) {
2461         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2462         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2463         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2464         RETPUSHUNDEF;
2465     }
2466 #if defined(HAS_FCNTL) && defined(F_SETFD)
2467     if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)       /* ensure close-on-exec */
2468         RETPUSHUNDEF;
2469 #endif
2470
2471     RETPUSHYES;
2472 }
2473 #endif
2474
2475 PP(pp_sockpair)
2476 {
2477 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2478     dSP;
2479     int fd[2];
2480     const int protocol = POPi;
2481     const int type = POPi;
2482     const int domain = POPi;
2483
2484     GV * const gv2 = MUTABLE_GV(POPs);
2485     IO * const io2 = GvIOn(gv2);
2486     GV * const gv1 = MUTABLE_GV(POPs);
2487     IO * const io1 = GvIOn(gv1);
2488
2489     if (IoIFP(io1))
2490         do_close(gv1, FALSE);
2491     if (IoIFP(io2))
2492         do_close(gv2, FALSE);
2493
2494     TAINT_PROPER("socketpair");
2495     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2496         RETPUSHUNDEF;
2497     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2498     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2499     IoTYPE(io1) = IoTYPE_SOCKET;
2500     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2501     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2502     IoTYPE(io2) = IoTYPE_SOCKET;
2503     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2504         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2505         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2506         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2507         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2508         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2509         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2510         RETPUSHUNDEF;
2511     }
2512 #if defined(HAS_FCNTL) && defined(F_SETFD)
2513     /* ensure close-on-exec */
2514     if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
2515         (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
2516         RETPUSHUNDEF;
2517 #endif
2518
2519     RETPUSHYES;
2520 #else
2521     DIE(aTHX_ PL_no_sock_func, "socketpair");
2522 #endif
2523 }
2524
2525 #ifdef HAS_SOCKET
2526
2527 /* also used for: pp_connect() */
2528
2529 PP(pp_bind)
2530 {
2531     dSP;
2532     SV * const addrsv = POPs;
2533     /* OK, so on what platform does bind modify addr?  */
2534     const char *addr;
2535     GV * const gv = MUTABLE_GV(POPs);
2536     IO * const io = GvIOn(gv);
2537     STRLEN len;
2538     int op_type;
2539     int fd;
2540
2541     if (!IoIFP(io))
2542         goto nuts;
2543     fd = PerlIO_fileno(IoIFP(io));
2544     if (fd < 0)
2545         goto nuts;
2546
2547     addr = SvPV_const(addrsv, len);
2548     op_type = PL_op->op_type;
2549     TAINT_PROPER(PL_op_desc[op_type]);
2550     if ((op_type == OP_BIND
2551          ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2552          : PerlSock_connect(fd, (struct sockaddr *)addr, len))
2553         >= 0)
2554         RETPUSHYES;
2555     else
2556         RETPUSHUNDEF;
2557
2558   nuts:
2559     report_evil_fh(gv);
2560     SETERRNO(EBADF,SS_IVCHAN);
2561     RETPUSHUNDEF;
2562 }
2563
2564 PP(pp_listen)
2565 {
2566     dSP;
2567     const int backlog = POPi;
2568     GV * const gv = MUTABLE_GV(POPs);
2569     IO * const io = GvIOn(gv);
2570
2571     if (!IoIFP(io))
2572         goto nuts;
2573
2574     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2575         RETPUSHYES;
2576     else
2577         RETPUSHUNDEF;
2578
2579   nuts:
2580     report_evil_fh(gv);
2581     SETERRNO(EBADF,SS_IVCHAN);
2582     RETPUSHUNDEF;
2583 }
2584
2585 PP(pp_accept)
2586 {
2587     dSP; dTARGET;
2588     IO *nstio;
2589     char namebuf[MAXPATHLEN];
2590 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2591     Sock_size_t len = sizeof (struct sockaddr_in);
2592 #else
2593     Sock_size_t len = sizeof namebuf;
2594 #endif
2595     GV * const ggv = MUTABLE_GV(POPs);
2596     GV * const ngv = MUTABLE_GV(POPs);
2597     int fd;
2598
2599     IO * const gstio = GvIO(ggv);
2600     if (!gstio || !IoIFP(gstio))
2601         goto nuts;
2602
2603     nstio = GvIOn(ngv);
2604     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2605 #if defined(OEMVS)
2606     if (len == 0) {
2607         /* Some platforms indicate zero length when an AF_UNIX client is
2608          * not bound. Simulate a non-zero-length sockaddr structure in
2609          * this case. */
2610         namebuf[0] = 0;        /* sun_len */
2611         namebuf[1] = AF_UNIX;  /* sun_family */
2612         len = 2;
2613     }
2614 #endif
2615
2616     if (fd < 0)
2617         goto badexit;
2618     if (IoIFP(nstio))
2619         do_close(ngv, FALSE);
2620     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2621     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2622     IoTYPE(nstio) = IoTYPE_SOCKET;
2623     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2624         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2625         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2626         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2627         goto badexit;
2628     }
2629 #if defined(HAS_FCNTL) && defined(F_SETFD)
2630     if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)       /* ensure close-on-exec */
2631         goto badexit;
2632 #endif
2633
2634 #ifdef __SCO_VERSION__
2635     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2636 #endif
2637
2638     PUSHp(namebuf, len);
2639     RETURN;
2640
2641   nuts:
2642     report_evil_fh(ggv);
2643     SETERRNO(EBADF,SS_IVCHAN);
2644
2645   badexit:
2646     RETPUSHUNDEF;
2647
2648 }
2649
2650 PP(pp_shutdown)
2651 {
2652     dSP; dTARGET;
2653     const int how = POPi;
2654     GV * const gv = MUTABLE_GV(POPs);
2655     IO * const io = GvIOn(gv);
2656
2657     if (!IoIFP(io))
2658         goto nuts;
2659
2660     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2661     RETURN;
2662
2663   nuts:
2664     report_evil_fh(gv);
2665     SETERRNO(EBADF,SS_IVCHAN);
2666     RETPUSHUNDEF;
2667 }
2668
2669
2670 /* also used for: pp_gsockopt() */
2671
2672 PP(pp_ssockopt)
2673 {
2674     dSP;
2675     const int optype = PL_op->op_type;
2676     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2677     const unsigned int optname = (unsigned int) POPi;
2678     const unsigned int lvl = (unsigned int) POPi;
2679     GV * const gv = MUTABLE_GV(POPs);
2680     IO * const io = GvIOn(gv);
2681     int fd;
2682     Sock_size_t len;
2683
2684     if (!IoIFP(io))
2685         goto nuts;
2686
2687     fd = PerlIO_fileno(IoIFP(io));
2688     if (fd < 0)
2689         goto nuts;
2690     switch (optype) {
2691     case OP_GSOCKOPT:
2692         SvGROW(sv, 257);
2693         (void)SvPOK_only(sv);
2694         SvCUR_set(sv,256);
2695         *SvEND(sv) ='\0';
2696         len = SvCUR(sv);
2697         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2698             goto nuts2;
2699 #if defined(_AIX)
2700         /* XXX Configure test: does getsockopt set the length properly? */
2701         if (len == 256)
2702             len = sizeof(int);
2703 #endif
2704         SvCUR_set(sv, len);
2705         *SvEND(sv) ='\0';
2706         PUSHs(sv);
2707         break;
2708     case OP_SSOCKOPT: {
2709 #if defined(__SYMBIAN32__)
2710 # define SETSOCKOPT_OPTION_VALUE_T void *
2711 #else
2712 # define SETSOCKOPT_OPTION_VALUE_T const char *
2713 #endif
2714         /* XXX TODO: We need to have a proper type (a Configure probe,
2715          * etc.) for what the C headers think of the third argument of
2716          * setsockopt(), the option_value read-only buffer: is it
2717          * a "char *", or a "void *", const or not.  Some compilers
2718          * don't take kindly to e.g. assuming that "char *" implicitly
2719          * promotes to a "void *", or to explicitly promoting/demoting
2720          * consts to non/vice versa.  The "const void *" is the SUS
2721          * definition, but that does not fly everywhere for the above
2722          * reasons. */
2723             SETSOCKOPT_OPTION_VALUE_T buf;
2724             int aint;
2725             if (SvPOKp(sv)) {
2726                 STRLEN l;
2727                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2728                 len = l;
2729             }
2730             else {
2731                 aint = (int)SvIV(sv);
2732                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2733                 len = sizeof(int);
2734             }
2735             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2736                 goto nuts2;
2737             PUSHs(&PL_sv_yes);
2738         }
2739         break;
2740     }
2741     RETURN;
2742
2743   nuts:
2744     report_evil_fh(gv);
2745     SETERRNO(EBADF,SS_IVCHAN);
2746   nuts2:
2747     RETPUSHUNDEF;
2748
2749 }
2750
2751
2752 /* also used for: pp_getsockname() */
2753
2754 PP(pp_getpeername)
2755 {
2756     dSP;
2757     const int optype = PL_op->op_type;
2758     GV * const gv = MUTABLE_GV(POPs);
2759     IO * const io = GvIOn(gv);
2760     Sock_size_t len;
2761     SV *sv;
2762     int fd;
2763
2764     if (!IoIFP(io))
2765         goto nuts;
2766
2767     sv = sv_2mortal(newSV(257));
2768     (void)SvPOK_only(sv);
2769     len = 256;
2770     SvCUR_set(sv, len);
2771     *SvEND(sv) ='\0';
2772     fd = PerlIO_fileno(IoIFP(io));
2773     if (fd < 0)
2774         goto nuts;
2775     switch (optype) {
2776     case OP_GETSOCKNAME:
2777         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2778             goto nuts2;
2779         break;
2780     case OP_GETPEERNAME:
2781         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2782             goto nuts2;
2783 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2784         {
2785             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";
2786             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2787             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2788                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2789                         sizeof(u_short) + sizeof(struct in_addr))) {
2790                 goto nuts2;     
2791             }
2792         }
2793 #endif
2794         break;
2795     }
2796 #ifdef BOGUS_GETNAME_RETURN
2797     /* Interactive Unix, getpeername() and getsockname()
2798       does not return valid namelen */
2799     if (len == BOGUS_GETNAME_RETURN)
2800         len = sizeof(struct sockaddr);
2801 #endif
2802     SvCUR_set(sv, len);
2803     *SvEND(sv) ='\0';
2804     PUSHs(sv);
2805     RETURN;
2806
2807   nuts:
2808     report_evil_fh(gv);
2809     SETERRNO(EBADF,SS_IVCHAN);
2810   nuts2:
2811     RETPUSHUNDEF;
2812 }
2813
2814 #endif
2815
2816 /* Stat calls. */
2817
2818 /* also used for: pp_lstat() */
2819
2820 PP(pp_stat)
2821 {
2822     dSP;
2823     GV *gv = NULL;
2824     IO *io = NULL;
2825     I32 gimme;
2826     I32 max = 13;
2827     SV* sv;
2828
2829     if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2830                                   : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
2831         if (PL_op->op_type == OP_LSTAT) {
2832             if (gv != PL_defgv) {
2833             do_fstat_warning_check:
2834                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2835                                "lstat() on filehandle%s%"SVf,
2836                                 gv ? " " : "",
2837                                 SVfARG(gv
2838                                         ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2839                                         : &PL_sv_no));
2840             } else if (PL_laststype != OP_LSTAT)
2841                 /* diag_listed_as: The stat preceding %s wasn't an lstat */
2842                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2843         }
2844
2845         if (gv != PL_defgv) {
2846             bool havefp;
2847           do_fstat_have_io:
2848             havefp = FALSE;
2849             PL_laststype = OP_STAT;
2850             PL_statgv = gv ? gv : (GV *)io;
2851             sv_setpvs(PL_statname, "");
2852             if(gv) {
2853                 io = GvIO(gv);
2854             }
2855             if (io) {
2856                     if (IoIFP(io)) {
2857                         int fd = PerlIO_fileno(IoIFP(io));
2858                         if (fd < 0) {
2859                             PL_laststatval = -1;
2860                             SETERRNO(EBADF,RMS_IFI);
2861                         } else {
2862                             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2863                             havefp = TRUE;
2864                         }
2865                     } else if (IoDIRP(io)) {
2866                         PL_laststatval =
2867                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2868                         havefp = TRUE;
2869                     } else {
2870                         PL_laststatval = -1;
2871                     }
2872             }
2873             else PL_laststatval = -1;
2874             if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
2875         }
2876
2877         if (PL_laststatval < 0) {
2878             max = 0;
2879         }
2880     }
2881     else {
2882         const char *file;
2883         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
2884             io = MUTABLE_IO(SvRV(sv));
2885             if (PL_op->op_type == OP_LSTAT)
2886                 goto do_fstat_warning_check;
2887             goto do_fstat_have_io; 
2888         }
2889         
2890         SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2891         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2892         PL_statgv = NULL;
2893         PL_laststype = PL_op->op_type;
2894         file = SvPV_nolen_const(PL_statname);
2895         if (PL_op->op_type == OP_LSTAT)
2896             PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
2897         else
2898             PL_laststatval = PerlLIO_stat(file, &PL_statcache);
2899         if (PL_laststatval < 0) {
2900             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
2901                 /* PL_warn_nl is constant */
2902                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2903                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2904                 GCC_DIAG_RESTORE;
2905             }
2906             max = 0;
2907         }
2908     }
2909
2910     gimme = GIMME_V;
2911     if (gimme != G_ARRAY) {
2912         if (gimme != G_VOID)
2913             XPUSHs(boolSV(max));
2914         RETURN;
2915     }
2916     if (max) {
2917         EXTEND(SP, max);
2918         EXTEND_MORTAL(max);
2919         mPUSHi(PL_statcache.st_dev);
2920 #if ST_INO_SIZE > IVSIZE
2921         mPUSHn(PL_statcache.st_ino);
2922 #else
2923 #   if ST_INO_SIGN <= 0
2924         mPUSHi(PL_statcache.st_ino);
2925 #   else
2926         mPUSHu(PL_statcache.st_ino);
2927 #   endif
2928 #endif
2929         mPUSHu(PL_statcache.st_mode);
2930         mPUSHu(PL_statcache.st_nlink);
2931         
2932         sv_setuid(PUSHmortal, PL_statcache.st_uid);
2933         sv_setgid(PUSHmortal, PL_statcache.st_gid);
2934
2935 #ifdef USE_STAT_RDEV
2936         mPUSHi(PL_statcache.st_rdev);
2937 #else
2938         PUSHs(newSVpvs_flags("", SVs_TEMP));
2939 #endif
2940 #if Off_t_size > IVSIZE
2941         mPUSHn(PL_statcache.st_size);
2942 #else
2943         mPUSHi(PL_statcache.st_size);
2944 #endif
2945 #ifdef BIG_TIME
2946         mPUSHn(PL_statcache.st_atime);
2947         mPUSHn(PL_statcache.st_mtime);
2948         mPUSHn(PL_statcache.st_ctime);
2949 #else
2950         mPUSHi(PL_statcache.st_atime);
2951         mPUSHi(PL_statcache.st_mtime);
2952         mPUSHi(PL_statcache.st_ctime);
2953 #endif
2954 #ifdef USE_STAT_BLOCKS
2955         mPUSHu(PL_statcache.st_blksize);
2956         mPUSHu(PL_statcache.st_blocks);
2957 #else
2958         PUSHs(newSVpvs_flags("", SVs_TEMP));
2959         PUSHs(newSVpvs_flags("", SVs_TEMP));
2960 #endif
2961     }
2962     RETURN;
2963 }
2964
2965 /* All filetest ops avoid manipulating the perl stack pointer in their main
2966    bodies (since commit d2c4d2d1e22d3125), and return using either
2967    S_ft_return_false() or S_ft_return_true().  These two helper functions are
2968    the only two which manipulate the perl stack.  To ensure that no stack
2969    manipulation macros are used, the filetest ops avoid defining a local copy
2970    of the stack pointer with dSP.  */
2971
2972 /* If the next filetest is stacked up with this one
2973    (PL_op->op_private & OPpFT_STACKING), we leave
2974    the original argument on the stack for success,
2975    and skip the stacked operators on failure.
2976    The next few macros/functions take care of this.
2977 */
2978
2979 static OP *
2980 S_ft_return_false(pTHX_ SV *ret) {
2981     OP *next = NORMAL;
2982     dSP;
2983
2984     if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
2985     else                           SETs(ret);
2986     PUTBACK;
2987
2988     if (PL_op->op_private & OPpFT_STACKING) {
2989         while (OP_IS_FILETEST(next->op_type)
2990                && next->op_private & OPpFT_STACKED)
2991             next = next->op_next;
2992     }
2993     return next;
2994 }
2995
2996 PERL_STATIC_INLINE OP *
2997 S_ft_return_true(pTHX_ SV *ret) {
2998     dSP;
2999     if (PL_op->op_flags & OPf_REF)
3000         XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3001     else if (!(PL_op->op_private & OPpFT_STACKING))
3002         SETs(ret);
3003     PUTBACK;
3004     return NORMAL;
3005 }
3006
3007 #define FT_RETURNNO     return S_ft_return_false(aTHX_ &PL_sv_no)
3008 #define FT_RETURNUNDEF  return S_ft_return_false(aTHX_ &PL_sv_undef)
3009 #define FT_RETURNYES    return S_ft_return_true(aTHX_ &PL_sv_yes)
3010
3011 #define tryAMAGICftest_MG(chr) STMT_START { \
3012         if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
3013                 && PL_op->op_flags & OPf_KIDS) {     \
3014             OP *next = S_try_amagic_ftest(aTHX_ chr);   \
3015             if (next) return next;                        \
3016         }                                                  \
3017     } STMT_END
3018
3019 STATIC OP *
3020 S_try_amagic_ftest(pTHX_ char chr) {
3021     SV *const arg = *PL_stack_sp;
3022
3023     assert(chr != '?');
3024     if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
3025
3026     if (SvAMAGIC(arg))
3027     {
3028         const char tmpchr = chr;
3029         SV * const tmpsv = amagic_call(arg,
3030                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3031                                 ftest_amg, AMGf_unary);
3032
3033         if (!tmpsv)
3034             return NULL;
3035
3036         return SvTRUE(tmpsv)
3037             ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
3038     }
3039     return NULL;
3040 }
3041
3042
3043 /* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3044  *                pp_ftrwrite() */
3045
3046 PP(pp_ftrread)
3047 {
3048     I32 result;
3049     /* Not const, because things tweak this below. Not bool, because there's
3050        no guarantee that OPpFT_ACCESS is <= CHAR_MAX  */
3051 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3052     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3053     /* Giving some sort of initial value silences compilers.  */
3054 #  ifdef R_OK
3055     int access_mode = R_OK;
3056 #  else
3057     int access_mode = 0;
3058 #  endif
3059 #else
3060     /* access_mode is never used, but leaving use_access in makes the
3061        conditional compiling below much clearer.  */
3062     I32 use_access = 0;
3063 #endif
3064     Mode_t stat_mode = S_IRUSR;
3065
3066     bool effective = FALSE;
3067     char opchar = '?';
3068
3069     switch (PL_op->op_type) {
3070     case OP_FTRREAD:    opchar = 'R'; break;
3071     case OP_FTRWRITE:   opchar = 'W'; break;
3072     case OP_FTREXEC:    opchar = 'X'; break;
3073     case OP_FTEREAD:    opchar = 'r'; break;
3074     case OP_FTEWRITE:   opchar = 'w'; break;
3075     case OP_FTEEXEC:    opchar = 'x'; break;
3076     }
3077     tryAMAGICftest_MG(opchar);
3078
3079     switch (PL_op->op_type) {
3080     case OP_FTRREAD:
3081 #if !(defined(HAS_ACCESS) && defined(R_OK))
3082         use_access = 0;
3083 #endif
3084         break;
3085
3086     case OP_FTRWRITE:
3087 #if defined(HAS_ACCESS) && defined(W_OK)
3088         access_mode = W_OK;
3089 #else
3090         use_access = 0;
3091 #endif
3092         stat_mode = S_IWUSR;
3093         break;
3094
3095     case OP_FTREXEC:
3096 #if defined(HAS_ACCESS) && defined(X_OK)
3097         access_mode = X_OK;
3098 #else
3099         use_access = 0;
3100 #endif
3101         stat_mode = S_IXUSR;
3102         break;
3103
3104     case OP_FTEWRITE:
3105 #ifdef PERL_EFF_ACCESS
3106         access_mode = W_OK;
3107 #endif
3108         stat_mode = S_IWUSR;
3109         /* FALLTHROUGH */
3110
3111     case OP_FTEREAD:
3112 #ifndef PERL_EFF_ACCESS
3113         use_access = 0;
3114 #endif
3115         effective = TRUE;
3116         break;
3117
3118     case OP_FTEEXEC:
3119 #ifdef PERL_EFF_ACCESS
3120         access_mode = X_OK;
3121 #else
3122         use_access = 0;
3123 #endif
3124         stat_mode = S_IXUSR;
3125         effective = TRUE;
3126         break;
3127     }
3128
3129     if (use_access) {
3130 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3131         const char *name = SvPV_nolen(*PL_stack_sp);
3132         if (effective) {
3133 #  ifdef PERL_EFF_ACCESS
3134             result = PERL_EFF_ACCESS(name, access_mode);
3135 #  else
3136             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3137                 OP_NAME(PL_op));
3138 #  endif
3139         }
3140         else {
3141 #  ifdef HAS_ACCESS
3142             result = access(name, access_mode);
3143 #  else
3144             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3145 #  endif
3146         }
3147         if (result == 0)
3148             FT_RETURNYES;
3149         if (result < 0)
3150             FT_RETURNUNDEF;
3151         FT_RETURNNO;
3152 #endif
3153     }
3154
3155     result = my_stat_flags(0);
3156     if (result < 0)
3157         FT_RETURNUNDEF;
3158     if (cando(stat_mode, effective, &PL_statcache))
3159         FT_RETURNYES;
3160     FT_RETURNNO;
3161 }
3162
3163
3164 /* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3165
3166 PP(pp_ftis)
3167 {
3168     I32 result;
3169     const int op_type = PL_op->op_type;
3170     char opchar = '?';
3171
3172     switch (op_type) {
3173     case OP_FTIS:       opchar = 'e'; break;
3174     case OP_FTSIZE:     opchar = 's'; break;
3175     case OP_FTMTIME:    opchar = 'M'; break;
3176     case OP_FTCTIME:    opchar = 'C'; break;
3177     case OP_FTATIME:    opchar = 'A'; break;
3178     }
3179     tryAMAGICftest_MG(opchar);
3180
3181     result = my_stat_flags(0);
3182     if (result < 0)
3183         FT_RETURNUNDEF;
3184     if (op_type == OP_FTIS)
3185         FT_RETURNYES;
3186     {
3187         /* You can't dTARGET inside OP_FTIS, because you'll get
3188            "panic: pad_sv po" - the op is not flagged to have a target.  */
3189         dTARGET;
3190         switch (op_type) {
3191         case OP_FTSIZE:
3192 #if Off_t_size > IVSIZE
3193             sv_setnv(TARG, (NV)PL_statcache.st_size);
3194 #else
3195             sv_setiv(TARG, (IV)PL_statcache.st_size);
3196 #endif
3197             break;
3198         case OP_FTMTIME:
3199             sv_setnv(TARG,
3200                     ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3201             break;
3202         case OP_FTATIME:
3203             sv_setnv(TARG,
3204                     ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3205             break;
3206         case OP_FTCTIME:
3207             sv_setnv(TARG,
3208                     ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3209             break;
3210         }
3211         SvSETMAGIC(TARG);
3212         return SvTRUE_nomg(TARG)
3213             ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
3214     }
3215 }
3216
3217
3218 /* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3219  *                pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3220  *                pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3221
3222 PP(pp_ftrowned)
3223 {
3224     I32 result;
3225     char opchar = '?';
3226
3227     switch (PL_op->op_type) {
3228     case OP_FTROWNED:   opchar = 'O'; break;
3229     case OP_FTEOWNED:   opchar = 'o'; break;
3230     case OP_FTZERO:     opchar = 'z'; break;
3231     case OP_FTSOCK:     opchar = 'S'; break;
3232     case OP_FTCHR:      opchar = 'c'; break;
3233     case OP_FTBLK:      opchar = 'b'; break;
3234     case OP_FTFILE:     opchar = 'f'; break;
3235     case OP_FTDIR:      opchar = 'd'; break;
3236     case OP_FTPIPE:     opchar = 'p'; break;
3237     case OP_FTSUID:     opchar = 'u'; break;
3238     case OP_FTSGID:     opchar = 'g'; break;
3239     case OP_FTSVTX:     opchar = 'k'; break;
3240     }
3241     tryAMAGICftest_MG(opchar);
3242
3243     /* I believe that all these three are likely to be defined on most every
3244        system these days.  */
3245 #ifndef S_ISUID
3246     if(PL_op->op_type == OP_FTSUID) {
3247         FT_RETURNNO;
3248     }
3249 #endif
3250 #ifndef S_ISGID
3251     if(PL_op->op_type == OP_FTSGID) {
3252         FT_RETURNNO;
3253     }
3254 #endif
3255 #ifndef S_ISVTX
3256     if(PL_op->op_type == OP_FTSVTX) {
3257         FT_RETURNNO;
3258     }
3259 #endif
3260
3261     result = my_stat_flags(0);
3262     if (result < 0)
3263         FT_RETURNUNDEF;
3264     switch (PL_op->op_type) {
3265     case OP_FTROWNED:
3266         if (PL_statcache.st_uid == PerlProc_getuid())
3267             FT_RETURNYES;
3268         break;
3269     case OP_FTEOWNED:
3270         if (PL_statcache.st_uid == PerlProc_geteuid())
3271             FT_RETURNYES;
3272         break;
3273     case OP_FTZERO:
3274         if (PL_statcache.st_size == 0)
3275             FT_RETURNYES;
3276         break;
3277     case OP_FTSOCK:
3278         if (S_ISSOCK(PL_statcache.st_mode))
3279             FT_RETURNYES;
3280         break;
3281     case OP_FTCHR:
3282         if (S_ISCHR(PL_statcache.st_mode))
3283             FT_RETURNYES;
3284         break;
3285     case OP_FTBLK:
3286         if (S_ISBLK(PL_statcache.st_mode))
3287             FT_RETURNYES;
3288         break;
3289     case OP_FTFILE:
3290         if (S_ISREG(PL_statcache.st_mode))
3291             FT_RETURNYES;
3292         break;
3293     case OP_FTDIR:
3294         if (S_ISDIR(PL_statcache.st_mode))
3295             FT_RETURNYES;
3296         break;
3297     case OP_FTPIPE:
3298         if (S_ISFIFO(PL_statcache.st_mode))
3299             FT_RETURNYES;
3300         break;
3301 #ifdef S_ISUID
3302     case OP_FTSUID:
3303         if (PL_statcache.st_mode & S_ISUID)
3304             FT_RETURNYES;
3305         break;
3306 #endif
3307 #ifdef S_ISGID
3308     case OP_FTSGID:
3309         if (PL_statcache.st_mode & S_ISGID)
3310             FT_RETURNYES;
3311         break;
3312 #endif
3313 #ifdef S_ISVTX
3314     case OP_FTSVTX:
3315         if (PL_statcache.st_mode & S_ISVTX)
3316             FT_RETURNYES;
3317         break;
3318 #endif
3319     }
3320     FT_RETURNNO;
3321 }
3322
3323 PP(pp_ftlink)
3324 {
3325     I32 result;
3326
3327     tryAMAGICftest_MG('l');
3328     result = my_lstat_flags(0);
3329
3330     if (result < 0)
3331         FT_RETURNUNDEF;
3332     if (S_ISLNK(PL_statcache.st_mode))
3333         FT_RETURNYES;
3334     FT_RETURNNO;
3335 }
3336
3337 PP(pp_fttty)
3338 {
3339     int fd;
3340     GV *gv;
3341     char *name = NULL;
3342     STRLEN namelen;
3343     UV uv;
3344
3345     tryAMAGICftest_MG('t');
3346
3347     if (PL_op->op_flags & OPf_REF)
3348         gv = cGVOP_gv;
3349     else {
3350       SV *tmpsv = *PL_stack_sp;
3351       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
3352         name = SvPV_nomg(tmpsv, namelen);
3353         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3354       }
3355     }
3356
3357     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3358         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3359     else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX)
3360         fd = (int)uv;
3361     else
3362         FT_RETURNUNDEF;
3363     if (fd < 0) {
3364         SETERRNO(EBADF,RMS_IFI);
3365         FT_RETURNUNDEF;
3366     }
3367     if (PerlLIO_isatty(fd))
3368         FT_RETURNYES;
3369     FT_RETURNNO;
3370 }
3371
3372
3373 /* also used for: pp_ftbinary() */
3374
3375 PP(pp_fttext)
3376 {
3377     I32 i;
3378     SSize_t len;
3379     I32 odd = 0;
3380     STDCHAR tbuf[512];
3381     STDCHAR *s;
3382     IO *io;
3383     SV *sv = NULL;
3384     GV *gv;
3385     PerlIO *fp;
3386
3387     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3388
3389     if (PL_op->op_flags & OPf_REF)
3390         gv = cGVOP_gv;
3391     else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3392              == OPpFT_STACKED)
3393         gv = PL_defgv;
3394     else {
3395         sv = *PL_stack_sp;
3396         gv = MAYBE_DEREF_GV_nomg(sv);
3397     }
3398
3399     if (gv) {
3400         if (gv == PL_defgv) {
3401             if (PL_statgv)
3402                 io = SvTYPE(PL_statgv) == SVt_PVIO
3403                     ? (IO *)PL_statgv
3404                     : GvIO(PL_statgv);
3405             else {
3406                 goto really_filename;
3407             }
3408         }
3409         else {
3410             PL_statgv = gv;
3411             sv_setpvs(PL_statname, "");
3412             io = GvIO(PL_statgv);
3413         }
3414         PL_laststatval = -1;
3415         PL_laststype = OP_STAT;
3416         if (io && IoIFP(io)) {
3417             int fd;
3418             if (! PerlIO_has_base(IoIFP(io)))
3419                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3420             fd = PerlIO_fileno(IoIFP(io));
3421             if (fd < 0) {
3422                 SETERRNO(EBADF,RMS_IFI);
3423                 FT_RETURNUNDEF;
3424             }
3425             PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3426             if (PL_laststatval < 0)
3427                 FT_RETURNUNDEF;
3428             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3429                 if (PL_op->op_type == OP_FTTEXT)
3430                     FT_RETURNNO;
3431                 else
3432                     FT_RETURNYES;
3433             }
3434             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3435                 i = PerlIO_getc(IoIFP(io));
3436                 if (i != EOF)
3437                     (void)PerlIO_ungetc(IoIFP(io),i);
3438                 else
3439                     /* null file is anything */
3440                     FT_RETURNYES;
3441             }
3442             len = PerlIO_get_bufsiz(IoIFP(io));
3443             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3444             /* sfio can have large buffers - limit to 512 */
3445             if (len > 512)
3446                 len = 512;
3447         }
3448         else {
3449             SETERRNO(EBADF,RMS_IFI);
3450             report_evil_fh(gv);
3451             SETERRNO(EBADF,RMS_IFI);
3452             FT_RETURNUNDEF;
3453         }
3454     }
3455     else {
3456         const char *file;
3457         int fd; 
3458
3459         assert(sv);
3460         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3461       really_filename:
3462         file = SvPVX_const(PL_statname);
3463         PL_statgv = NULL;
3464         if (!(fp = PerlIO_open(file, "r"))) {
3465             if (!gv) {
3466                 PL_laststatval = -1;
3467                 PL_laststype = OP_STAT;
3468             }
3469             if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
3470                 /* PL_warn_nl is constant */
3471                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3472                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3473                 GCC_DIAG_RESTORE;
3474             }
3475             FT_RETURNUNDEF;
3476         }
3477         PL_laststype = OP_STAT;
3478         fd = PerlIO_fileno(fp);
3479         if (fd < 0) {
3480             (void)PerlIO_close(fp);
3481             SETERRNO(EBADF,RMS_IFI);
3482             FT_RETURNUNDEF;
3483         }
3484         PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
3485         if (PL_laststatval < 0) {
3486             (void)PerlIO_close(fp);
3487             SETERRNO(EBADF,RMS_IFI);
3488             FT_RETURNUNDEF;
3489         }
3490         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3491         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3492         (void)PerlIO_close(fp);
3493         if (len <= 0) {
3494             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3495                 FT_RETURNNO;            /* special case NFS directories */
3496             FT_RETURNYES;               /* null file is anything */
3497         }
3498         s = tbuf;
3499     }
3500
3501     /* now scan s to look for textiness */
3502
3503 #if defined(DOSISH) || defined(USEMYBINMODE)
3504     /* ignore trailing ^Z on short files */
3505     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3506         --len;
3507 #endif
3508
3509     assert(len);
3510     if (! is_invariant_string((U8 *) s, len)) {
3511         const U8 *ep;
3512
3513         /* Here contains a variant under UTF-8 .  See if the entire string is
3514          * UTF-8.  But the buffer may end in a partial character, so consider
3515          * it UTF-8 if the first non-UTF8 char is an ending partial */
3516         if (is_utf8_string_loc((U8 *) s, len, &ep)
3517             || ep + UTF8SKIP(ep)  > (U8 *) (s + len))
3518         {
3519             if (PL_op->op_type == OP_FTTEXT) {
3520                 FT_RETURNYES;
3521             }
3522             else {
3523                 FT_RETURNNO;
3524             }
3525         }
3526     }
3527
3528     /* Here, is not UTF-8 or is entirely ASCII.  Look through the buffer for
3529      * things that wouldn't be in ASCII text or rich ASCII text.  Count these
3530      * in 'odd' */
3531     for (i = 0; i < len; i++, s++) {
3532         if (!*s) {                      /* null never allowed in text */
3533             odd += len;
3534             break;
3535         }
3536 #ifdef USE_LOCALE_CTYPE
3537         if (IN_LC_RUNTIME(LC_CTYPE)) {
3538             if ( isPRINT_LC(*s) || isSPACE_LC(*s)) {
3539                 continue;
3540             }
3541         }
3542         else
3543 #endif
3544         if (isPRINT_A(*s)
3545                    /* VT occurs so rarely in text, that we consider it odd */
3546                 || (isSPACE_A(*s) && *s != VT_NATIVE)
3547
3548                     /* But there is a fair amount of backspaces and escapes in
3549                      * some text */
3550                 || *s == '\b'
3551                 || *s == ESC_NATIVE)
3552         {
3553             continue;
3554         }
3555         odd++;
3556     }
3557
3558     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3559         FT_RETURNNO;
3560     else
3561         FT_RETURNYES;
3562 }
3563
3564 /* File calls. */
3565
3566 PP(pp_chdir)
3567 {
3568     dSP; dTARGET;
3569     const char *tmps = NULL;
3570     GV *gv = NULL;
3571
3572     if( MAXARG == 1 ) {
3573         SV * const sv = POPs;
3574         if (PL_op->op_flags & OPf_SPECIAL) {
3575             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3576         }
3577         else if (!(gv = MAYBE_DEREF_GV(sv)))
3578                 tmps = SvPV_nomg_const_nolen(sv);
3579     }
3580
3581     if( !gv && (!tmps || !*tmps) ) {
3582         HV * const table = GvHVn(PL_envgv);
3583         SV **svp;
3584
3585         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3586              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3587 #ifdef VMS
3588              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3589 #endif
3590            )
3591         {
3592             if( MAXARG == 1 )
3593                 deprecate("chdir('') or chdir(undef) as chdir()");
3594             tmps = SvPV_nolen_const(*svp);
3595         }
3596         else {
3597             PUSHi(0);
3598             TAINT_PROPER("chdir");
3599             RETURN;
3600         }
3601     }
3602
3603     TAINT_PROPER("chdir");
3604     if (gv) {
3605 #ifdef HAS_FCHDIR
3606         IO* const io = GvIO(gv);
3607         if (io) {
3608             if (IoDIRP(io)) {
3609                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3610             } else if (IoIFP(io)) {
3611                 int fd = PerlIO_fileno(IoIFP(io));
3612                 if (fd < 0) {
3613                     goto nuts;
3614                 }
3615                 PUSHi(fchdir(fd) >= 0);
3616             }
3617             else {
3618                 goto nuts;
3619             }
3620         } else {
3621             goto nuts;
3622         }
3623
3624 #else
3625         DIE(aTHX_ PL_no_func, "fchdir");
3626 #endif
3627     }
3628     else 
3629         PUSHi( PerlDir_chdir(tmps) >= 0 );
3630 #ifdef VMS
3631     /* Clear the DEFAULT element of ENV so we'll get the new value
3632      * in the future. */
3633     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3634 #endif
3635     RETURN;
3636
3637 #ifdef HAS_FCHDIR
3638  nuts:
3639     report_evil_fh(gv);
3640     SETERRNO(EBADF,RMS_IFI);
3641     PUSHi(0);
3642     RETURN;
3643 #endif
3644 }
3645
3646
3647 /* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */
3648
3649 PP(pp_chown)
3650 {
3651     dSP; dMARK; dTARGET;
3652     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3653
3654     SP = MARK;
3655     XPUSHi(value);
3656     RETURN;
3657 }
3658
3659 PP(pp_chroot)
3660 {
3661 #ifdef HAS_CHROOT
3662     dSP; dTARGET;
3663     char * const tmps = POPpx;
3664     TAINT_PROPER("chroot");
3665     PUSHi( chroot(tmps) >= 0 );
3666     RETURN;
3667 #else
3668     DIE(aTHX_ PL_no_func, "chroot");
3669 #endif
3670 }
3671
3672 PP(pp_rename)
3673 {
3674     dSP; dTARGET;
3675     int anum;
3676     const char * const tmps2 = POPpconstx;
3677     const char * const tmps = SvPV_nolen_const(TOPs);
3678     TAINT_PROPER("rename");
3679 #ifdef HAS_RENAME
3680     anum = PerlLIO_rename(tmps, tmps2);
3681 #else
3682     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3683         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3684             anum = 1;
3685         else {
3686             if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3687                 (void)UNLINK(tmps2);
3688             if (!(anum = link(tmps, tmps2)))
3689                 anum = UNLINK(tmps);
3690         }
3691     }
3692 #endif
3693     SETi( anum >= 0 );
3694     RETURN;
3695 }
3696
3697
3698 /* also used for: pp_symlink() */
3699
3700 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3701 PP(pp_link)
3702 {
3703     dSP; dTARGET;
3704     const int op_type = PL_op->op_type;
3705     int result;
3706
3707 #  ifndef HAS_LINK
3708     if (op_type == OP_LINK)
3709         DIE(aTHX_ PL_no_func, "link");
3710 #  endif
3711 #  ifndef HAS_SYMLINK
3712     if (op_type == OP_SYMLINK)
3713         DIE(aTHX_ PL_no_func, "symlink");
3714 #  endif
3715
3716     {
3717         const char * const tmps2 = POPpconstx;
3718         const char * const tmps = SvPV_nolen_const(TOPs);
3719         TAINT_PROPER(PL_op_desc[op_type]);
3720         result =
3721 #  if defined(HAS_LINK)
3722 #    if defined(HAS_SYMLINK)
3723             /* Both present - need to choose which.  */
3724             (op_type == OP_LINK) ?
3725             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3726 #    else
3727     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3728         PerlLIO_link(tmps, tmps2);
3729 #    endif
3730 #  else
3731 #    if defined(HAS_SYMLINK)
3732     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3733         symlink(tmps, tmps2);
3734 #    endif
3735 #  endif
3736     }
3737
3738     SETi( result >= 0 );
3739     RETURN;
3740 }
3741 #else
3742
3743 /* also used for: pp_symlink() */
3744
3745 PP(pp_link)
3746 {
3747     /* Have neither.  */
3748     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3749 }
3750 #endif
3751
3752 PP(pp_readlink)
3753 {
3754     dSP;
3755 #ifdef HAS_SYMLINK
3756     dTARGET;
3757     const char *tmps;
3758     char buf[MAXPATHLEN];
3759     SSize_t len;
3760
3761     TAINT;
3762     tmps = POPpconstx;
3763     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
3764      * it is impossible to know whether the result was truncated. */
3765     len = readlink(tmps, buf, sizeof(buf) - 1);
3766     if (len < 0)
3767         RETPUSHUNDEF;
3768     if (len != -1)
3769         buf[len] = '\0';
3770     PUSHp(buf, len);
3771     RETURN;
3772 #else
3773     EXTEND(SP, 1);
3774     RETSETUNDEF;                /* just pretend it's a normal file */
3775 #endif
3776 }
3777
3778 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3779 STATIC int
3780 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3781 {
3782     char * const save_filename = filename;
3783     char *cmdline;
3784     char *s;
3785     PerlIO *myfp;
3786     int anum = 1;
3787     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3788
3789     PERL_ARGS_ASSERT_DOONELINER;
3790
3791     Newx(cmdline, size, char);
3792     my_strlcpy(cmdline, cmd, size);
3793     my_strlcat(cmdline, " ", size);
3794     for (s = cmdline + strlen(cmdline); *filename; ) {
3795         *s++ = '\\';
3796         *s++ = *filename++;
3797     }
3798     if (s - cmdline < size)
3799         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3800     myfp = PerlProc_popen(cmdline, "r");
3801     Safefree(cmdline);
3802
3803     if (myfp) {
3804         SV * const tmpsv = sv_newmortal();
3805         /* Need to save/restore 'PL_rs' ?? */
3806         s = sv_gets(tmpsv, myfp, 0);
3807         (void)PerlProc_pclose(myfp);
3808         if (s != NULL) {
3809             int e;
3810             for (e = 1;
3811 #ifdef HAS_SYS_ERRLIST
3812                  e <= sys_nerr
3813 #endif
3814                  ; e++)
3815             {
3816                 /* you don't see this */
3817                 const char * const errmsg = Strerror(e) ;
3818                 if (!errmsg)
3819                     break;
3820                 if (instr(s, errmsg)) {
3821                     SETERRNO(e,0);
3822                     return 0;
3823                 }
3824             }
3825             SETERRNO(0,0);
3826 #ifndef EACCES
3827 #define EACCES EPERM
3828 #endif
3829             if (instr(s, "cannot make"))
3830                 SETERRNO(EEXIST,RMS_FEX);
3831             else if (instr(s, "existing file"))
3832                 SETERRNO(EEXIST,RMS_FEX);
3833             else if (instr(s, "ile exists"))
3834                 SETERRNO(EEXIST,RMS_FEX);
3835             else if (instr(s, "non-exist"))
3836                 SETERRNO(ENOENT,RMS_FNF);
3837             else if (instr(s, "does not exist"))
3838                 SETERRNO(ENOENT,RMS_FNF);
3839             else if (instr(s, "not empty"))
3840                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3841             else if (instr(s, "cannot access"))
3842                 SETERRNO(EACCES,RMS_PRV);
3843             else
3844                 SETERRNO(EPERM,RMS_PRV);
3845             return 0;
3846         }
3847         else {  /* some mkdirs return no failure indication */
3848             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3849             if (PL_op->op_type == OP_RMDIR)
3850                 anum = !anum;
3851             if (anum)
3852                 SETERRNO(0,0);
3853             else
3854                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3855         }
3856         return anum;
3857     }
3858     else
3859         return 0;
3860 }
3861 #endif
3862
3863 /* This macro removes trailing slashes from a directory name.
3864  * Different operating and file systems take differently to
3865  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3866  * any number of trailing slashes should be allowed.
3867  * Thusly we snip them away so that even non-conforming
3868  * systems are happy.
3869  * We should probably do this "filtering" for all
3870  * the functions that expect (potentially) directory names:
3871  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3872  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3873
3874 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3875     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3876         do { \
3877             (len)--; \
3878         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3879         (tmps) = savepvn((tmps), (len)); \
3880         (copy) = TRUE; \
3881     }
3882
3883 PP(pp_mkdir)
3884 {
3885     dSP; dTARGET;
3886     STRLEN len;
3887     const char *tmps;
3888     bool copy = FALSE;
3889     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3890
3891     TRIMSLASHES(tmps,len,copy);
3892
3893     TAINT_PROPER("mkdir");
3894 #ifdef HAS_MKDIR
3895     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3896 #else
3897     {
3898     int oldumask;
3899     SETi( dooneliner("mkdir", tmps) );
3900     oldumask = PerlLIO_umask(0);
3901     PerlLIO_umask(oldumask);
3902     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3903     }
3904 #endif
3905     if (copy)
3906         Safefree(tmps);
3907     RETURN;
3908 }
3909
3910 PP(pp_rmdir)
3911 {
3912     dSP; dTARGET;
3913     STRLEN len;
3914     const char *tmps;
3915     bool copy = FALSE;
3916
3917     TRIMSLASHES(tmps,len,copy);
3918     TAINT_PROPER("rmdir");
3919 #ifdef HAS_RMDIR
3920     SETi( PerlDir_rmdir(tmps) >= 0 );
3921 #else
3922     SETi( dooneliner("rmdir", tmps) );
3923 #endif
3924     if (copy)
3925         Safefree(tmps);
3926     RETURN;
3927 }
3928
3929 /* Directory calls. */
3930
3931 PP(pp_open_dir)
3932 {
3933 #if defined(Direntry_t) && defined(HAS_READDIR)
3934     dSP;
3935     const char * const dirname = POPpconstx;
3936     GV * const gv = MUTABLE_GV(POPs);
3937     IO * const io = GvIOn(gv);
3938
3939     if ((IoIFP(io) || IoOFP(io)))
3940         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3941                          "Opening filehandle %"HEKf" also as a directory",
3942                              HEKfARG(GvENAME_HEK(gv)) );
3943     if (IoDIRP(io))
3944         PerlDir_close(IoDIRP(io));
3945     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3946         goto nope;
3947
3948     RETPUSHYES;
3949   nope:
3950     if (!errno)
3951         SETERRNO(EBADF,RMS_DIR);
3952     RETPUSHUNDEF;
3953 #else
3954     DIE(aTHX_ PL_no_dir_func, "opendir");
3955 #endif
3956 }
3957
3958 PP(pp_readdir)
3959 {
3960 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3961     DIE(aTHX_ PL_no_dir_func, "readdir");
3962 #else
3963 #if !defined(I_DIRENT) && !defined(VMS)
3964     Direntry_t *readdir (DIR *);
3965 #endif
3966     dSP;
3967
3968     SV *sv;
3969     const I32 gimme = GIMME_V;
3970     GV * const gv = MUTABLE_GV(POPs);
3971     const Direntry_t *dp;
3972     IO * const io = GvIOn(gv);
3973
3974     if (!IoDIRP(io)) {
3975         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3976                        "readdir() attempted on invalid dirhandle %"HEKf,
3977                             HEKfARG(GvENAME_HEK(gv)));
3978         goto nope;
3979     }
3980
3981     do {
3982         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3983         if (!dp)
3984             break;
3985 #ifdef DIRNAMLEN
3986         sv = newSVpvn(dp->d_name, dp->d_namlen);
3987 #else
3988         sv = newSVpv(dp->d_name, 0);
3989 #endif
3990         if (!(IoFLAGS(io) & IOf_UNTAINT))
3991             SvTAINTED_on(sv);
3992         mXPUSHs(sv);
3993     } while (gimme == G_ARRAY);
3994
3995     if (!dp && gimme != G_ARRAY)
3996         RETPUSHUNDEF;
3997
3998     RETURN;
3999
4000   nope:
4001     if (!errno)
4002         SETERRNO(EBADF,RMS_ISI);
4003     if (gimme == G_ARRAY)
4004         RETURN;
4005     else
4006         RETPUSHUNDEF;
4007 #endif
4008 }
4009
4010 PP(pp_telldir)
4011 {
4012 #if defined(HAS_TELLDIR) || defined(telldir)
4013     dSP; dTARGET;
4014  /* XXX does _anyone_ need this? --AD 2/20/1998 */
4015  /* XXX netbsd still seemed to.
4016     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
4017     --JHI 1999-Feb-02 */
4018 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
4019     long telldir (DIR *);
4020 # endif
4021     GV * const gv = MUTABLE_GV(POPs);
4022     IO * const io = GvIOn(gv);
4023
4024     if (!IoDIRP(io)) {
4025         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4026                        "telldir() attempted on invalid dirhandle %"HEKf,
4027                             HEKfARG(GvENAME_HEK(gv)));
4028         goto nope;
4029     }
4030
4031     PUSHi( PerlDir_tell(IoDIRP(io)) );
4032     RETURN;
4033   nope:
4034     if (!errno)
4035         SETERRNO(EBADF,RMS_ISI);
4036     RETPUSHUNDEF;
4037 #else
4038     DIE(aTHX_ PL_no_dir_func, "telldir");
4039 #endif
4040 }
4041
4042 PP(pp_seekdir)
4043 {
4044 #if defined(HAS_SEEKDIR) || defined(seekdir)
4045     dSP;
4046     const long along = POPl;
4047     GV * const gv = MUTABLE_GV(POPs);
4048     IO * const io = GvIOn(gv);
4049
4050     if (!IoDIRP(io)) {
4051         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4052                        "seekdir() attempted on invalid dirhandle %"HEKf,
4053                                 HEKfARG(GvENAME_HEK(gv)));
4054         goto nope;
4055     }
4056     (void)PerlDir_seek(IoDIRP(io), along);
4057
4058     RETPUSHYES;
4059   nope:
4060     if (!errno)
4061         SETERRNO(EBADF,RMS_ISI);
4062     RETPUSHUNDEF;
4063 #else
4064     DIE(aTHX_ PL_no_dir_func, "seekdir");
4065 #endif
4066 }
4067
4068 PP(pp_rewinddir)
4069 {
4070 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4071     dSP;
4072     GV * const gv = MUTABLE_GV(POPs);
4073     IO * const io = GvIOn(gv);
4074
4075     if (!IoDIRP(io)) {
4076         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4077                        "rewinddir() attempted on invalid dirhandle %"HEKf,
4078                                 HEKfARG(GvENAME_HEK(gv)));
4079         goto nope;
4080     }
4081     (void)PerlDir_rewind(IoDIRP(io));
4082     RETPUSHYES;
4083   nope:
4084     if (!errno)
4085         SETERRNO(EBADF,RMS_ISI);
4086     RETPUSHUNDEF;
4087 #else
4088     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4089 #endif
4090 }
4091
4092 PP(pp_closedir)
4093 {
4094 #if defined(Direntry_t) && defined(HAS_READDIR)
4095     dSP;
4096     GV * const gv = MUTABLE_GV(POPs);
4097     IO * const io = GvIOn(gv);
4098
4099     if (!IoDIRP(io)) {
4100         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4101                        "closedir() attempted on invalid dirhandle %"HEKf,
4102                                 HEKfARG(GvENAME_HEK(gv)));
4103         goto nope;
4104     }
4105 #ifdef VOID_CLOSEDIR
4106     PerlDir_close(IoDIRP(io));
4107 #else
4108     if (PerlDir_close(IoDIRP(io)) < 0) {
4109         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4110         goto nope;
4111     }
4112 #endif
4113     IoDIRP(io) = 0;
4114
4115     RETPUSHYES;
4116   nope:
4117     if (!errno)
4118         SETERRNO(EBADF,RMS_IFI);
4119     RETPUSHUNDEF;
4120 #else
4121     DIE(aTHX_ PL_no_dir_func, "closedir");
4122 #endif
4123 }
4124
4125 /* Process control. */
4126
4127 PP(pp_fork)
4128 {
4129 #ifdef HAS_FORK
4130     dSP; dTARGET;
4131     Pid_t childpid;
4132 #ifdef HAS_SIGPROCMASK
4133     sigset_t oldmask, newmask;
4134 #endif
4135
4136     EXTEND(SP, 1);
4137     PERL_FLUSHALL_FOR_CHILD;
4138 #ifdef HAS_SIGPROCMASK
4139     sigfillset(&newmask);
4140     sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4141 #endif
4142     childpid = PerlProc_fork();
4143     if (childpid == 0) {
4144         int sig;
4145         PL_sig_pending = 0;
4146         if (PL_psig_pend)
4147             for (sig = 1; sig < SIG_SIZE; sig++)
4148                 PL_psig_pend[sig] = 0;
4149     }
4150 #ifdef HAS_SIGPROCMASK
4151     {
4152         dSAVE_ERRNO;
4153         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4154         RESTORE_ERRNO;
4155     }
4156 #endif
4157     if (childpid < 0)
4158         RETPUSHUNDEF;
4159     if (!childpid) {
4160 #ifdef PERL_USES_PL_PIDSTATUS
4161         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4162 #endif
4163     }
4164     PUSHi(childpid);
4165     RETURN;
4166 #else
4167 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4168     dSP; dTARGET;
4169     Pid_t childpid;
4170
4171     EXTEND(SP, 1);
4172     PERL_FLUSHALL_FOR_CHILD;
4173     childpid = PerlProc_fork();
4174     if (childpid == -1)
4175         RETPUSHUNDEF;
4176     PUSHi(childpid);
4177     RETURN;
4178 #  else
4179     DIE(aTHX_ PL_no_func, "fork");
4180 #  endif
4181 #endif
4182 }
4183
4184 PP(pp_wait)
4185 {
4186 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4187     dSP; dTARGET;
4188     Pid_t childpid;
4189     int argflags;
4190
4191     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4192         childpid = wait4pid(-1, &argflags, 0);
4193     else {
4194         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4195                errno == EINTR) {
4196           PERL_ASYNC_CHECK();
4197         }
4198     }
4199 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4200     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4201     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4202 #  else
4203     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4204 #  endif
4205     XPUSHi(childpid);
4206     RETURN;
4207 #else
4208     DIE(aTHX_ PL_no_func, "wait");
4209 #endif
4210 }
4211
4212 PP(pp_waitpid)
4213 {
4214 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4215     dSP; dTARGET;
4216     const int optype = POPi;
4217     const Pid_t pid = TOPi;
4218     Pid_t result;
4219     int argflags;
4220
4221     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4222         result = wait4pid(pid, &argflags, optype);
4223     else {
4224         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4225                errno == EINTR) {
4226           PERL_ASYNC_CHECK();
4227         }
4228     }
4229 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4230     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4231     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4232 #  else
4233     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4234 #  endif
4235     SETi(result);
4236     RETURN;
4237 #else
4238     DIE(aTHX_ PL_no_func, "waitpid");
4239 #endif
4240 }
4241
4242 PP(pp_system)
4243 {
4244     dSP; dMARK; dORIGMARK; dTARGET;
4245 #if defined(__LIBCATAMOUNT__)
4246     PL_statusvalue = -1;
4247     SP = ORIGMARK;
4248     XPUSHi(-1);
4249 #else
4250     I32 value;
4251     int result;
4252
4253     if (TAINTING_get) {
4254         TAINT_ENV();
4255         while (++MARK <= SP) {
4256             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4257             if (TAINT_get)
4258                 break;
4259         }
4260         MARK = ORIGMARK;
4261         TAINT_PROPER("system");
4262     }
4263     PERL_FLUSHALL_FOR_CHILD;
4264 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4265     {
4266         Pid_t childpid;
4267         int pp[2];
4268         I32 did_pipes = 0;
4269 #ifdef HAS_SIGPROCMASK
4270         sigset_t newset, oldset;
4271 #endif
4272
4273         if (PerlProc_pipe(pp) >= 0)
4274             did_pipes = 1;
4275 #ifdef HAS_SIGPROCMASK
4276         sigemptyset(&newset);
4277         sigaddset(&newset, SIGCHLD);
4278         sigprocmask(SIG_BLOCK, &newset, &oldset);
4279 #endif
4280         while ((childpid = PerlProc_fork()) == -1) {
4281             if (errno != EAGAIN) {
4282                 value = -1;
4283                 SP = ORIGMARK;
4284                 XPUSHi(value);
4285                 if (did_pipes) {
4286                     PerlLIO_close(pp[0]);
4287                     PerlLIO_close(pp[1]);
4288                 }
4289 #ifdef HAS_SIGPROCMASK
4290                 sigprocmask(SIG_SETMASK, &oldset, NULL);
4291 #endif
4292                 RETURN;
4293             }
4294             sleep(5);
4295         }
4296         if (childpid > 0) {
4297             Sigsave_t ihand,qhand; /* place to save signals during system() */
4298             int status;
4299
4300             if (did_pipes)
4301                 PerlLIO_close(pp[1]);
4302 #ifndef PERL_MICRO
4303             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4304             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4305 #endif
4306             do {
4307                 result = wait4pid(childpid, &status, 0);
4308             } while (result == -1 && errno == EINTR);
4309 #ifndef PERL_MICRO
4310 #ifdef HAS_SIGPROCMASK
4311             sigprocmask(SIG_SETMASK, &oldset, NULL);
4312 #endif
4313             (void)rsignal_restore(SIGINT, &ihand);
4314             (void)rsignal_restore(SIGQUIT, &qhand);
4315 #endif
4316             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4317             do_execfree();      /* free any memory child malloced on fork */
4318             SP = ORIGMARK;
4319             if (did_pipes) {
4320                 int errkid;
4321                 unsigned n = 0;
4322                 SSize_t n1;
4323
4324                 while (n < sizeof(int)) {
4325                     n1 = PerlLIO_read(pp[0],
4326                                       (void*)(((char*)&errkid)+n),
4327                                       (sizeof(int)) - n);
4328                     if (n1 <= 0)
4329                         break;
4330                     n += n1;
4331                 }
4332                 PerlLIO_close(pp[0]);
4333                 if (n) {                        /* Error */
4334                     if (n != sizeof(int))
4335                         DIE(aTHX_ "panic: kid popen errno read, n=%u", n);
4336                     errno = errkid;             /* Propagate errno from kid */
4337                     STATUS_NATIVE_CHILD_SET(-1);
4338                 }
4339             }
4340             XPUSHi(STATUS_CURRENT);
4341             RETURN;
4342         }
4343 #ifdef HAS_SIGPROCMASK
4344         sigprocmask(SIG_SETMASK, &oldset, NULL);
4345 #endif
4346         if (did_pipes) {
4347             PerlLIO_close(pp[0]);
4348 #if defined(HAS_FCNTL) && defined(F_SETFD)
4349             if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
4350                 RETPUSHUNDEF;
4351 #endif
4352         }
4353         if (PL_op->op_flags & OPf_STACKED) {
4354             SV * const really = *++MARK;
4355             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4356         }
4357         else if (SP - MARK != 1)
4358             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4359         else {
4360             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4361         }
4362         PerlProc__exit(-1);
4363     }
4364 #else /* ! FORK or VMS or OS/2 */
4365     PL_statusvalue = 0;
4366     result = 0;
4367     if (PL_op->op_flags & OPf_STACKED) {
4368         SV * const really = *++MARK;
4369 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4370         value = (I32)do_aspawn(really, MARK, SP);
4371 #  else
4372         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4373 #  endif
4374     }
4375     else if (SP - MARK != 1) {
4376 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4377         value = (I32)do_aspawn(NULL, MARK, SP);
4378 #  else
4379         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4380 #  endif
4381     }
4382     else {
4383         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4384     }
4385     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4386         result = 1;
4387     STATUS_NATIVE_CHILD_SET(value);
4388     do_execfree();
4389     SP = ORIGMARK;
4390     XPUSHi(result ? value : STATUS_CURRENT);
4391 #endif /* !FORK or VMS or OS/2 */
4392 #endif
4393     RETURN;
4394 }
4395
4396 PP(pp_exec)
4397 {
4398     dSP; dMARK; dORIGMARK; dTARGET;
4399     I32 value;
4400
4401     if (TAINTING_get) {
4402         TAINT_ENV();
4403         while (++MARK <= SP) {
4404             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4405             if (TAINT_get)
4406                 break;
4407         }
4408         MARK = ORIGMARK;
4409         TAINT_PROPER("exec");
4410     }
4411     PERL_FLUSHALL_FOR_CHILD;
4412     if (PL_op->op_flags & OPf_STACKED) {
4413         SV * const really = *++MARK;
4414         value = (I32)do_aexec(really, MARK, SP);
4415     }
4416     else if (SP - MARK != 1)
4417 #ifdef VMS
4418         value = (I32)vms_do_aexec(NULL, MARK, SP);
4419 #else
4420         value = (I32)do_aexec(NULL, MARK, SP);
4421 #endif
4422     else {
4423 #ifdef VMS
4424         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4425 #else
4426         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4427 #endif
4428     }
4429
4430     SP = ORIGMARK;
4431     XPUSHi(value);
4432     RETURN;
4433 }
4434
4435 PP(pp_getppid)
4436 {
4437 #ifdef HAS_GETPPID
4438     dSP; dTARGET;
4439     XPUSHi( getppid() );
4440     RETURN;
4441 #else
4442     DIE(aTHX_ PL_no_func, "getppid");
4443 #endif
4444 }
4445
4446 PP(pp_getpgrp)
4447 {
4448 #ifdef HAS_GETPGRP
4449     dSP; dTARGET;
4450     Pid_t pgrp;
4451     const Pid_t pid =
4452         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4453
4454 #ifdef BSD_GETPGRP
4455     pgrp = (I32)BSD_GETPGRP(pid);
4456 #else
4457     if (pid != 0 && pid != PerlProc_getpid())
4458         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4459     pgrp = getpgrp();
4460 #endif
4461     XPUSHi(pgrp);
4462     RETURN;
4463 #else
4464     DIE(aTHX_ PL_no_func, "getpgrp");
4465 #endif
4466 }
4467
4468 PP(pp_setpgrp)
4469 {
4470 #ifdef HAS_SETPGRP
4471     dSP; dTARGET;
4472     Pid_t pgrp;
4473     Pid_t pid;
4474     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4475     if (MAXARG > 0) pid = TOPs ? TOPi : 0;
4476     else {
4477         pid = 0;
4478         EXTEND(SP,1);
4479         SP++;
4480     }
4481
4482     TAINT_PROPER("setpgrp");
4483 #ifdef BSD_SETPGRP
4484     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4485 #else
4486     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4487         || (pid != 0 && pid != PerlProc_getpid()))
4488     {
4489         DIE(aTHX_ "setpgrp can't take arguments");
4490     }
4491     SETi( setpgrp() >= 0 );
4492 #endif /* USE_BSDPGRP */
4493     RETURN;
4494 #else
4495     DIE(aTHX_ PL_no_func, "setpgrp");
4496 #endif
4497 }
4498
4499 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4500 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4501 #else
4502 #  define PRIORITY_WHICH_T(which) which
4503 #endif
4504
4505 PP(pp_getpriority)
4506 {
4507 #ifdef HAS_GETPRIORITY
4508     dSP; dTARGET;
4509     const int who = POPi;
4510     const int which = TOPi;
4511     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4512     RETURN;
4513 #else
4514     DIE(aTHX_ PL_no_func, "getpriority");
4515 #endif
4516 }
4517
4518 PP(pp_setpriority)
4519 {
4520 #ifdef HAS_SETPRIORITY
4521     dSP; dTARGET;
4522     const int niceval = POPi;
4523     const int who = POPi;
4524     const int which = TOPi;
4525     TAINT_PROPER("setpriority");
4526     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4527     RETURN;
4528 #else
4529     DIE(aTHX_ PL_no_func, "setpriority");
4530 #endif
4531 }
4532
4533 #undef PRIORITY_WHICH_T
4534
4535 /* Time calls. */
4536
4537 PP(pp_time)
4538 {
4539     dSP; dTARGET;
4540 #ifdef BIG_TIME
4541     XPUSHn( time(NULL) );
4542 #else
4543     XPUSHi( time(NULL) );
4544 #endif
4545     RETURN;
4546 }
4547
4548 PP(pp_tms)
4549 {
4550 #ifdef HAS_TIMES
4551     dSP;
4552     struct tms timesbuf;
4553
4554     EXTEND(SP, 4);
4555     (void)PerlProc_times(&timesbuf);
4556
4557     mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick);
4558     if (GIMME_V == G_ARRAY) {
4559         mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick);
4560         mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick);
4561         mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick);
4562     }
4563     RETURN;
4564 #else
4565 #   ifdef PERL_MICRO
4566     dSP;
4567     mPUSHn(0.0);
4568     EXTEND(SP, 4);
4569     if (GIMME_V == G_ARRAY) {
4570          mPUSHn(0.0);
4571          mPUSHn(0.0);
4572          mPUSHn(0.0);
4573     }
4574     RETURN;
4575 #   else
4576     DIE(aTHX_ "times not implemented");
4577 #   endif
4578 #endif /* HAS_TIMES */
4579 }
4580
4581 /* The 32 bit int year limits the times we can represent to these
4582    boundaries with a few days wiggle room to account for time zone
4583    offsets
4584 */
4585 /* Sat Jan  3 00:00:00 -2147481748 */
4586 #define TIME_LOWER_BOUND -67768100567755200.0
4587 /* Sun Dec 29 12:00:00  2147483647 */
4588 #define TIME_UPPER_BOUND  67767976233316800.0
4589
4590
4591 /* also used for: pp_localtime() */
4592
4593 PP(pp_gmtime)
4594 {
4595     dSP;
4596     Time64_T when;
4597     struct TM tmbuf;
4598     struct TM *err;
4599     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4600     static const char * const dayname[] =
4601         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4602     static const char * const monname[] =
4603         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4604          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4605
4606     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4607         time_t now;
4608         (void)time(&now);
4609         when = (Time64_T)now;
4610     }
4611     else {
4612         NV input = Perl_floor(POPn);
4613         const bool pl_isnan = Perl_isnan(input);
4614         when = (Time64_T)input;
4615         if (UNLIKELY(pl_isnan || when != input)) {
4616             /* diag_listed_as: gmtime(%f) too large */
4617             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4618                            "%s(%.0" NVff ") too large", opname, input);
4619             if (pl_isnan) {
4620                 err = NULL;
4621                 goto failed;
4622             }
4623         }
4624     }
4625
4626     if ( TIME_LOWER_BOUND > when ) {
4627         /* diag_listed_as: gmtime(%f) too small */
4628         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4629                        "%s(%.0" NVff ") too small", opname, when);
4630         err = NULL;
4631     }
4632     else if( when > TIME_UPPER_BOUND ) {
4633         /* diag_listed_as: gmtime(%f) too small */
4634         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4635                        "%s(%.0" NVff ") too large", opname, when);
4636         err = NULL;
4637     }
4638     else {
4639         if (PL_op->op_type == OP_LOCALTIME)
4640             err = S_localtime64_r(&when, &tmbuf);
4641         else
4642             err = S_gmtime64_r(&when, &tmbuf);
4643     }
4644
4645     if (err == NULL) {
4646         /* diag_listed_as: gmtime(%f) failed */
4647         /* XXX %lld broken for quads */
4648       failed:
4649         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4650                        "%s(%.0" NVff ") failed", opname, when);
4651     }
4652
4653     if (GIMME_V != G_ARRAY) {   /* scalar context */
4654         EXTEND(SP, 1);
4655         if (err == NULL)
4656             RETPUSHUNDEF;
4657        else {
4658            dTARGET;
4659            PUSHs(TARG);
4660            Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf,
4661                                 dayname[tmbuf.tm_wday],
4662                                 monname[tmbuf.tm_mon],
4663                                 tmbuf.tm_mday,
4664                                 tmbuf.tm_hour,
4665                                 tmbuf.tm_min,
4666                                 tmbuf.tm_sec,
4667                                 (IV)tmbuf.tm_year + 1900);
4668         }
4669     }
4670     else {                      /* list context */
4671         if ( err == NULL )
4672             RETURN;
4673
4674         EXTEND(SP, 9);
4675         EXTEND_MORTAL(9);
4676         mPUSHi(tmbuf.tm_sec);
4677         mPUSHi(tmbuf.tm_min);
4678         mPUSHi(tmbuf.tm_hour);
4679         mPUSHi(tmbuf.tm_mday);
4680         mPUSHi(tmbuf.tm_mon);
4681         mPUSHn(tmbuf.tm_year);
4682         mPUSHi(tmbuf.tm_wday);
4683         mPUSHi(tmbuf.tm_yday);
4684         mPUSHi(tmbuf.tm_isdst);
4685     }
4686     RETURN;
4687 }
4688
4689 PP(pp_alarm)
4690 {
4691 #ifdef HAS_ALARM
4692     dSP; dTARGET;
4693     int anum;
4694     anum = POPi;
4695     anum = alarm((unsigned int)anum);
4696     if (anum < 0)
4697         RETPUSHUNDEF;
4698     PUSHi(anum);
4699     RETURN;
4700 #else
4701     DIE(aTHX_ PL_no_func, "alarm");
4702 #endif
4703 }
4704
4705 PP(pp_sleep)
4706 {
4707     dSP; dTARGET;
4708     I32 duration;
4709     Time_t lasttime;
4710     Time_t when;
4711
4712     (void)time(&lasttime);
4713     if (MAXARG < 1 || (!TOPs && !POPs))
4714         PerlProc_pause();
4715     else {
4716         duration = POPi;
4717         PerlProc_sleep((unsigned int)duration);
4718     }
4719     (void)time(&when);
4720     XPUSHi(when - lasttime);
4721     RETURN;
4722 }
4723
4724 /* Shared memory. */
4725 /* Merged with some message passing. */
4726
4727 /* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */
4728
4729 PP(pp_shmwrite)
4730 {
4731 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4732     dSP; dMARK; dTARGET;
4733     const int op_type = PL_op->op_type;
4734     I32 value;
4735
4736     switch (op_type) {
4737     case OP_MSGSND:
4738         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4739         break;
4740     case OP_MSGRCV:
4741         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4742         break;
4743     case OP_SEMOP:
4744         value = (I32)(do_semop(MARK, SP) >= 0);
4745         break;
4746     default:
4747         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4748         break;
4749     }
4750
4751     SP = MARK;
4752     PUSHi(value);
4753     RETURN;
4754 #else
4755     return Perl_pp_semget(aTHX);
4756 #endif
4757 }
4758
4759 /* Semaphores. */
4760
4761 /* also used for: pp_msgget() pp_shmget() */
4762
4763 PP(pp_semget)
4764 {
4765 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4766     dSP; dMARK; dTARGET;
4767     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4768     SP = MARK;
4769     if (anum == -1)
4770         RETPUSHUNDEF;
4771     PUSHi(anum);
4772     RETURN;
4773 #else
4774     DIE(aTHX_ "System V IPC is not implemented on this machine");
4775 #endif
4776 }
4777
4778 /* also used for: pp_msgctl() pp_shmctl() */
4779
4780 PP(pp_semctl)
4781 {
4782 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4783     dSP; dMARK; dTARGET;
4784     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4785     SP = MARK;
4786     if (anum == -1)
4787         RETPUSHUNDEF;
4788     if (anum != 0) {
4789         PUSHi(anum);
4790     }
4791     else {
4792         PUSHp(zero_but_true, ZBTLEN);
4793     }
4794     RETURN;
4795 #else
4796     return Perl_pp_semget(aTHX);
4797 #endif
4798 }
4799
4800 /* I can't const this further without getting warnings about the types of
4801    various arrays passed in from structures.  */
4802 static SV *
4803 S_space_join_names_mortal(pTHX_ char *const *array)
4804 {
4805     SV *target;
4806
4807     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4808
4809     if (*array) {
4810         target = newSVpvs_flags("", SVs_TEMP);
4811         while (1) {
4812             sv_catpv(target, *array);
4813             if (!*++array)
4814                 break;
4815             sv_catpvs(target, " ");
4816         }
4817     } else {
4818         target = sv_mortalcopy(&PL_sv_no);
4819     }
4820     return target;
4821 }
4822
4823 /* Get system info. */
4824
4825 /* also used for: pp_ghbyaddr() pp_ghbyname() */
4826
4827 PP(pp_ghostent)
4828 {
4829 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4830     dSP;
4831     I32 which = PL_op->op_type;
4832     char **elem;
4833     SV *sv;
4834 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4835     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4836     struct hostent *gethostbyname(Netdb_name_t);
4837     struct hostent *gethostent(void);
4838 #endif
4839     struct hostent *hent = NULL;
4840     unsigned long len;
4841
4842     EXTEND(SP, 10);
4843     if (which == OP_GHBYNAME) {
4844 #ifdef HAS_GETHOSTBYNAME
4845         const char* const name = POPpbytex;
4846         hent = PerlSock_gethostbyname(name);
4847 #else
4848         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4849 #endif
4850     }
4851     else if (which == OP_GHBYADDR) {
4852 #ifdef HAS_GETHOSTBYADDR
4853         const int addrtype = POPi;
4854         SV * const addrsv = POPs;
4855         STRLEN addrlen;
4856         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4857
4858         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4859 #else
4860         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4861 #endif
4862     }
4863     else
4864 #ifdef HAS_GETHOSTENT
4865         hent = PerlSock_gethostent();
4866 #else
4867         DIE(aTHX_ PL_no_sock_func, "gethostent");
4868 #endif
4869
4870 #ifdef HOST_NOT_FOUND
4871         if (!hent) {
4872 #ifdef USE_REENTRANT_API
4873 #   ifdef USE_GETHOSTENT_ERRNO
4874             h_errno = PL_reentrant_buffer->_gethostent_errno;
4875 #   endif
4876 #endif
4877             STATUS_UNIX_SET(h_errno);
4878         }
4879 #endif
4880
4881     if (GIMME_V != G_ARRAY) {
4882         PUSHs(sv = sv_newmortal());
4883         if (hent) {
4884             if (which == OP_GHBYNAME) {
4885                 if (hent->h_addr)
4886                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4887             }
4888             else
4889                 sv_setpv(sv, (char*)hent->h_name);
4890         }
4891         RETURN;
4892     }
4893
4894     if (hent) {
4895         mPUSHs(newSVpv((char*)hent->h_name, 0));
4896         PUSHs(space_join_names_mortal(hent->h_aliases));
4897         mPUSHi(hent->h_addrtype);
4898         len = hent->h_length;
4899         mPUSHi(len);
4900 #ifdef h_addr
4901         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4902             mXPUSHp(*elem, len);
4903         }
4904 #else
4905         if (hent->h_addr)
4906             mPUSHp(hent->h_addr, len);
4907         else
4908             PUSHs(sv_mortalcopy(&PL_sv_no));
4909 #endif /* h_addr */
4910     }
4911     RETURN;
4912 #else
4913     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4914 #endif
4915 }
4916
4917 /* also used for: pp_gnbyaddr() pp_gnbyname() */
4918
4919 PP(pp_gnetent)
4920 {
4921 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4922     dSP;
4923     I32 which = PL_op->op_type;
4924     SV *sv;
4925 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4926     struct netent *getnetbyaddr(Netdb_net_t, int);
4927     struct netent *getnetbyname(Netdb_name_t);
4928     struct netent *getnetent(void);
4929 #endif
4930     struct netent *nent;
4931
4932     if (which == OP_GNBYNAME){
4933 #ifdef HAS_GETNETBYNAME
4934         const char * const name = POPpbytex;
4935         nent = PerlSock_getnetbyname(name);
4936 #else
4937         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4938 #endif
4939     }
4940     else if (which == OP_GNBYADDR) {
4941 #ifdef HAS_GETNETBYADDR
4942         const int addrtype = POPi;
4943         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4944         nent = PerlSock_getnetbyaddr(addr, addrtype);
4945 #else
4946         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4947 #endif
4948     }
4949     else
4950 #ifdef HAS_GETNETENT
4951         nent = PerlSock_getnetent();
4952 #else
4953         DIE(aTHX_ PL_no_sock_func, "getnetent");
4954 #endif
4955
4956 #ifdef HOST_NOT_FOUND
4957         if (!nent) {
4958 #ifdef USE_REENTRANT_API
4959 #   ifdef USE_GETNETENT_ERRNO
4960              h_errno = PL_reentrant_buffer->_getnetent_errno;
4961 #   endif
4962 #endif
4963             STATUS_UNIX_SET(h_errno);
4964         }
4965 #endif
4966
4967     EXTEND(SP, 4);
4968     if (GIMME_V != G_ARRAY) {
4969         PUSHs(sv = sv_newmortal());
4970         if (nent) {
4971             if (which == OP_GNBYNAME)
4972                 sv_setiv(sv, (IV)nent->n_net);
4973             else
4974                 sv_setpv(sv, nent->n_name);
4975         }
4976         RETURN;
4977     }
4978
4979     if (nent) {
4980         mPUSHs(newSVpv(nent->n_name, 0));
4981         PUSHs(space_join_names_mortal(nent->n_aliases));
4982         mPUSHi(nent->n_addrtype);
4983         mPUSHi(nent->n_net);
4984     }
4985
4986     RETURN;
4987 #else
4988     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4989 #endif
4990 }
4991
4992
4993 /* also used for: pp_gpbyname() pp_gpbynumber() */
4994
4995 PP(pp_gprotoent)
4996 {
4997 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4998     dSP;
4999     I32 which = PL_op->op_type;
5000     SV *sv;
5001 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
5002     struct protoent *getprotobyname(Netdb_name_t);
5003     struct protoent *getprotobynumber(int);
5004     struct protoent *getprotoent(void);
5005 #endif
5006     struct protoent *pent;
5007
5008     if (which == OP_GPBYNAME) {
5009 #ifdef HAS_GETPROTOBYNAME
5010         const char* const name = POPpbytex;
5011         pent = PerlSock_getprotobyname(name);
5012 #else
5013         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
5014 #endif
5015     }
5016     else if (which == OP_GPBYNUMBER) {
5017 #ifdef HAS_GETPROTOBYNUMBER
5018         const int number = POPi;
5019         pent = PerlSock_getprotobynumber(number);
5020 #else
5021         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
5022 #endif
5023     }
5024     else
5025 #ifdef HAS_GETPROTOENT
5026         pent = PerlSock_getprotoent();
5027 #else
5028         DIE(aTHX_ PL_no_sock_func, "getprotoent");
5029 #endif
5030
5031     EXTEND(SP, 3);
5032     if (GIMME_V != G_ARRAY) {
5033         PUSHs(sv = sv_newmortal());
5034         if (pent) {
5035             if (which == OP_GPBYNAME)
5036                 sv_setiv(sv, (IV)pent->p_proto);
5037             else
5038                 sv_setpv(sv, pent->p_name);
5039         }
5040         RETURN;
5041     }
5042
5043     if (pent) {
5044         mPUSHs(newSVpv(pent->p_name, 0));
5045         PUSHs(space_join_names_mortal(pent->p_aliases));
5046         mPUSHi(pent->p_proto);
5047     }
5048
5049     RETURN;
5050 #else
5051     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5052 #endif
5053 }
5054
5055
5056 /* also used for: pp_gsbyname() pp_gsbyport() */
5057
5058 PP(pp_gservent)
5059 {
5060 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5061     dSP;
5062     I32 which = PL_op->op_type;
5063     SV *sv;
5064 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5065     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5066     struct servent *getservbyport(int, Netdb_name_t);
5067     struct servent *getservent(void);
5068 #endif
5069     struct servent *sent;
5070
5071     if (which == OP_GSBYNAME) {
5072 #ifdef HAS_GETSERVBYNAME
5073         const char * const proto = POPpbytex;
5074         const char * const name = POPpbytex;
5075         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5076 #else
5077         DIE(aTHX_ PL_no_sock_func, "getservbyname");
5078 #endif
5079     }
5080     else if (which == OP_GSBYPORT) {
5081 #ifdef HAS_GETSERVBYPORT
5082         const char * const proto = POPpbytex;
5083         unsigned short port = (unsigned short)POPu;
5084         port = PerlSock_htons(port);
5085         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5086 #else
5087         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5088 #endif
5089     }
5090     else
5091 #ifdef HAS_GETSERVENT
5092         sent = PerlSock_getservent();
5093 #else
5094         DIE(aTHX_ PL_no_sock_func, "getservent");
5095 #endif
5096
5097     EXTEND(SP, 4);
5098     if (GIMME_V != G_ARRAY) {
5099         PUSHs(sv = sv_newmortal());
5100         if (sent) {
5101             if (which == OP_GSBYNAME) {
5102                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5103             }
5104             else
5105                 sv_setpv(sv, sent->s_name);
5106         }
5107         RETURN;
5108     }
5109
5110     if (sent) {
5111         mPUSHs(newSVpv(sent->s_name, 0));
5112         PUSHs(space_join_names_mortal(sent->s_aliases));
5113         mPUSHi(PerlSock_ntohs(sent->s_port));
5114         mPUSHs(newSVpv(sent->s_proto, 0));
5115     }
5116
5117     RETURN;
5118 #else
5119     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5120 #endif
5121 }
5122
5123
5124 /* also used for: pp_snetent() pp_sprotoent() pp_sservent() */
5125
5126 PP(pp_shostent)
5127 {
5128     dSP;
5129     const int stayopen = TOPi;
5130     switch(PL_op->op_type) {
5131     case OP_SHOSTENT:
5132 #ifdef HAS_SETHOSTENT
5133         PerlSock_sethostent(stayopen);
5134 #else
5135         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5136 #endif
5137         break;
5138 #ifdef HAS_SETNETENT
5139     case OP_SNETENT:
5140         PerlSock_setnetent(stayopen);
5141 #else
5142         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5143 #endif
5144         break;
5145     case OP_SPROTOENT:
5146 #ifdef HAS_SETPROTOENT
5147         PerlSock_setprotoent(stayopen);
5148 #else
5149         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5150 #endif
5151         break;
5152     case OP_SSERVENT:
5153 #ifdef HAS_SETSERVENT
5154         PerlSock_setservent(stayopen);
5155 #else
5156         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5157 #endif
5158         break;
5159     }
5160     RETSETYES;
5161 }
5162
5163
5164 /* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent()
5165  *                pp_eservent() pp_sgrent() pp_spwent() */
5166
5167 PP(pp_ehostent)
5168 {
5169     dSP;
5170     switch(PL_op->op_type) {
5171     case OP_EHOSTENT:
5172 #ifdef HAS_ENDHOSTENT
5173         PerlSock_endhostent();
5174 #else
5175         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5176 #endif
5177         break;
5178     case OP_ENETENT:
5179 #ifdef HAS_ENDNETENT
5180         PerlSock_endnetent();
5181 #else
5182         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5183 #endif
5184         break;
5185     case OP_EPROTOENT:
5186 #ifdef HAS_ENDPROTOENT
5187         PerlSock_endprotoent();
5188 #else
5189         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5190 #endif
5191         break;
5192     case OP_ESERVENT:
5193 #ifdef HAS_ENDSERVENT
5194         PerlSock_endservent();
5195 #else
5196         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5197 #endif
5198         break;
5199     case OP_SGRENT:
5200 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5201         setgrent();
5202 #else
5203         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5204 #endif
5205         break;
5206     case OP_EGRENT:
5207 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5208         endgrent();
5209 #else
5210         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5211 #endif
5212         break;
5213     case OP_SPWENT:
5214 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5215         setpwent();
5216 #else
5217         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5218 #endif
5219         break;
5220     case OP_EPWENT:
5221 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5222         endpwent();
5223 #else
5224         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5225 #endif
5226         break;
5227     }
5228     EXTEND(SP,1);
5229     RETPUSHYES;
5230 }
5231
5232
5233 /* also used for: pp_gpwnam() pp_gpwuid() */
5234
5235 PP(pp_gpwent)
5236 {
5237 #ifdef HAS_PASSWD
5238     dSP;
5239     I32 which = PL_op->op_type;
5240     SV *sv;
5241     struct passwd *pwent  = NULL;
5242     /*
5243      * We currently support only the SysV getsp* shadow password interface.
5244      * The interface is declared in <shadow.h> and often one needs to link
5245      * with -lsecurity or some such.
5246      * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5247      * (and SCO?)
5248      *
5249      * AIX getpwnam() is clever enough to return the encrypted password
5250      * only if the caller (euid?) is root.
5251      *
5252      * There are at least three other shadow password APIs.  Many platforms
5253      * seem to contain more than one interface for accessing the shadow
5254      * password databases, possibly for compatibility reasons.
5255      * The getsp*() is by far he simplest one, the other two interfaces
5256      * are much more complicated, but also very similar to each other.
5257      *
5258      * <sys/types.h>
5259      * <sys/security.h>
5260      * <prot.h>
5261      * struct pr_passwd *getprpw*();
5262      * The password is in
5263      * char getprpw*(...).ufld.fd_encrypt[]
5264      * Mention HAS_GETPRPWNAM here so that Configure probes for it.
5265      *
5266      * <sys/types.h>
5267      * <sys/security.h>
5268      * <prot.h>
5269      * struct es_passwd *getespw*();
5270      * The password is in
5271      * char *(getespw*(...).ufld.fd_encrypt)
5272      * Mention HAS_GETESPWNAM here so that Configure probes for it.
5273      *
5274      * <userpw.h> (AIX)
5275      * struct userpw *getuserpw();
5276      * The password is in
5277      * char *(getuserpw(...)).spw_upw_passwd
5278      * (but the de facto standard getpwnam() should work okay)
5279      *
5280      * Mention I_PROT here so that Configure probes for it.
5281      *
5282      * In HP-UX for getprpw*() the manual page claims that one should include
5283      * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5284      * if one includes <shadow.h> as that includes <hpsecurity.h>,
5285      * and pp_sys.c already includes <shadow.h> if there is such.
5286      *
5287      * Note that <sys/security.h> is already probed for, but currently
5288      * it is only included in special cases.
5289      *
5290      * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5291      * be preferred interface, even though also the getprpw*() interface
5292      * is available) one needs to link with -lsecurity -ldb -laud -lm.
5293      * One also needs to call set_auth_parameters() in main() before
5294      * doing anything else, whether one is using getespw*() or getprpw*().
5295      *
5296      * Note that accessing the shadow databases can be magnitudes
5297      * slower than accessing the standard databases.
5298      *
5299      * --jhi
5300      */
5301
5302 #   if defined(__CYGWIN__) && defined(USE_REENTRANT_API)
5303     /* Cygwin 1.5.3-1 has buggy getpwnam_r() and getpwuid_r():
5304      * the pw_comment is left uninitialized. */
5305     PL_reentrant_buffer->_pwent_struct.pw_comment = NULL;
5306 #   endif
5307
5308     switch (which) {
5309     case OP_GPWNAM:
5310       {
5311         const char* const name = POPpbytex;
5312         pwent  = getpwnam(name);
5313       }
5314       break;
5315     case OP_GPWUID:
5316       {
5317         Uid_t uid = POPi;
5318         pwent = getpwuid(uid);
5319       }
5320         break;
5321     case OP_GPWENT:
5322 #   ifdef HAS_GETPWENT
5323         pwent  = getpwent();
5324 #ifdef POSIX_BC   /* In some cases pw_passwd has invalid addresses */
5325         if (pwent) pwent = getpwnam(pwent->pw_name);
5326 #endif
5327 #   else
5328         DIE(aTHX_ PL_no_func, "getpwent");
5329 #   endif
5330         break;
5331     }
5332
5333     EXTEND(SP, 10);
5334     if (GIMME_V != G_ARRAY) {
5335         PUSHs(sv = sv_newmortal());
5336         if (pwent) {
5337             if (which == OP_GPWNAM)
5338                 sv_setuid(sv, pwent->pw_uid);
5339             else
5340                 sv_setpv(sv, pwent->pw_name);
5341         }
5342         RETURN;
5343     }
5344
5345     if (pwent) {
5346         mPUSHs(newSVpv(pwent->pw_name, 0));
5347
5348         sv = newSViv(0);
5349         mPUSHs(sv);
5350         /* If we have getspnam(), we try to dig up the shadow
5351          * password.  If we are underprivileged, the shadow
5352          * interface will set the errno to EACCES or similar,
5353          * and return a null pointer.  If this happens, we will
5354          * use the dummy password (usually "*" or "x") from the
5355          * standard password database.
5356          *
5357          * In theory we could skip the shadow call completely
5358          * if euid != 0 but in practice we cannot know which
5359          * security measures are guarding the shadow databases
5360          * on a random platform.
5361          *
5362          * Resist the urge to use additional shadow interfaces.
5363          * Divert the urge to writing an extension instead.
5364          *
5365          * --jhi */
5366         /* Some AIX setups falsely(?) detect some getspnam(), which
5367          * has a different API than the Solaris/IRIX one. */
5368 #   if defined(HAS_GETSPNAM) && !defined(_AIX)
5369         {
5370             dSAVE_ERRNO;
5371             const struct spwd * const spwent = getspnam(pwent->pw_name);
5372                           /* Save and restore errno so that
5373                            * underprivileged attempts seem
5374                            * to have never made the unsuccessful
5375                            * attempt to retrieve the shadow password. */
5376             RESTORE_ERRNO;
5377             if (spwent && spwent->sp_pwdp)
5378                 sv_setpv(sv, spwent->sp_pwdp);
5379         }
5380 #   endif
5381 #   ifdef PWPASSWD
5382         if (!SvPOK(sv)) /* Use the standard password, then. */
5383             sv_setpv(sv, pwent->pw_passwd);
5384 #   endif
5385
5386         /* passwd is tainted because user himself can diddle with it.
5387          * admittedly not much and in a very limited way, but nevertheless. */
5388         SvTAINTED_on(sv);
5389
5390         sv_setuid(PUSHmortal, pwent->pw_uid);
5391         sv_setgid(PUSHmortal, pwent->pw_gid);
5392
5393         /* pw_change, pw_quota, and pw_age are mutually exclusive--
5394          * because of the poor interface of the Perl getpw*(),
5395          * not because there's some standard/convention saying so.
5396          * A better interface would have been to return a hash,
5397          * but we are accursed by our history, alas. --jhi.  */
5398 #   ifdef PWCHANGE
5399         mPUSHi(pwent->pw_change);
5400 #   else
5401 #       ifdef PWQUOTA
5402         mPUSHi(pwent->pw_quota);
5403 #       else
5404 #           ifdef PWAGE
5405         mPUSHs(newSVpv(pwent->pw_age, 0));
5406 #           else
5407         /* I think that you can never get this compiled, but just in case.  */
5408         PUSHs(sv_mortalcopy(&PL_sv_no));
5409 #           endif
5410 #       endif
5411 #   endif
5412
5413         /* pw_class and pw_comment are mutually exclusive--.
5414          * see the above note for pw_change, pw_quota, and pw_age. */
5415 #   ifdef PWCLASS
5416         mPUSHs(newSVpv(pwent->pw_class, 0));
5417 #   else
5418 #       ifdef PWCOMMENT
5419         mPUSHs(newSVpv(pwent->pw_comment, 0));
5420 #       else
5421         /* I think that you can never get this compiled, but just in case.  */
5422         PUSHs(sv_mortalcopy(&PL_sv_no));
5423 #       endif
5424 #   endif
5425
5426 #   ifdef PWGECOS
5427         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_gecos, 0)));
5428 #   else
5429         PUSHs(sv = sv_mortalcopy(&PL_sv_no));
5430 #   endif
5431         /* pw_gecos is tainted because user himself can diddle with it. */
5432         SvTAINTED_on(sv);
5433
5434         mPUSHs(newSVpv(pwent->pw_dir, 0));
5435
5436         PUSHs(sv = sv_2mortal(newSVpv(pwent->pw_shell, 0)));
5437         /* pw_shell is tainted because user himself can diddle with it. */
5438         SvTAINTED_on(sv);
5439
5440 #   ifdef PWEXPIRE
5441         mPUSHi(pwent->pw_expire);
5442 #   endif
5443     }
5444     RETURN;
5445 #else
5446     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5447 #endif
5448 }
5449
5450
5451 /* also used for: pp_ggrgid() pp_ggrnam() */
5452
5453 PP(pp_ggrent)
5454 {
5455 #ifdef HAS_GROUP
5456     dSP;
5457     const I32 which = PL_op->op_type;
5458     const struct group *grent;
5459
5460     if (which == OP_GGRNAM) {
5461         const char* const name = POPpbytex;
5462         grent = (const struct group *)getgrnam(name);
5463     }
5464     else if (which == OP_GGRGID) {
5465         const Gid_t gid = POPi;
5466         grent = (const struct group *)getgrgid(gid);
5467     }
5468     else
5469 #ifdef HAS_GETGRENT
5470         grent = (struct group *)getgrent();
5471 #else
5472         DIE(aTHX_ PL_no_func, "getgrent");
5473 #endif
5474
5475     EXTEND(SP, 4);
5476     if (GIMME_V != G_ARRAY) {
5477         SV * const sv = sv_newmortal();
5478
5479         PUSHs(sv);
5480         if (grent) {
5481             if (which == OP_GGRNAM)
5482                 sv_setgid(sv, grent->gr_gid);
5483             else
5484                 sv_setpv(sv, grent->gr_name);
5485         }
5486         RETURN;
5487     }
5488
5489     if (grent) {
5490         mPUSHs(newSVpv(grent->gr_name, 0));
5491
5492 #ifdef GRPASSWD
5493         mPUSHs(newSVpv(grent->gr_passwd, 0));
5494 #else
5495         PUSHs(sv_mortalcopy(&PL_sv_no));
5496 #endif
5497
5498         sv_setgid(PUSHmortal, grent->gr_gid);
5499
5500 #if !(defined(_CRAYMPP) && defined(USE_REENTRANT_API))
5501         /* In UNICOS/mk (_CRAYMPP) the multithreading
5502          * versions (getgrnam_r, getgrgid_r)
5503          * seem to return an illegal pointer
5504          * as the group members list, gr_mem.
5505          * getgrent() doesn't even have a _r version
5506          * but the gr_mem is poisonous anyway.
5507          * So yes, you cannot get the list of group
5508          * members if building multithreaded in UNICOS/mk. */
5509         PUSHs(space_join_names_mortal(grent->gr_mem));
5510 #endif
5511     }
5512
5513     RETURN;
5514 #else
5515     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5516 #endif
5517 }
5518
5519 PP(pp_getlogin)
5520 {
5521 #ifdef HAS_GETLOGIN
5522     dSP; dTARGET;
5523     char *tmps;
5524     EXTEND(SP, 1);
5525     if (!(tmps = PerlProc_getlogin()))
5526         RETPUSHUNDEF;
5527     sv_setpv_mg(TARG, tmps);
5528     PUSHs(TARG);
5529     RETURN;
5530 #else
5531     DIE(aTHX_ PL_no_func, "getlogin");
5532 #endif
5533 }
5534
5535 /* Miscellaneous. */
5536
5537 PP(pp_syscall)
5538 {
5539 #ifdef HAS_SYSCALL
5540     dSP; dMARK; dORIGMARK; dTARGET;
5541     I32 items = SP - MARK;
5542     unsigned long a[20];
5543     I32 i = 0;
5544     IV retval = -1;
5545
5546     if (TAINTING_get) {
5547         while (++MARK <= SP) {
5548             if (SvTAINTED(*MARK)) {
5549                 TAINT;
5550                 break;
5551             }
5552         }
5553         MARK = ORIGMARK;
5554         TAINT_PROPER("syscall");
5555     }
5556
5557     /* This probably won't work on machines where sizeof(long) != sizeof(int)
5558      * or where sizeof(long) != sizeof(char*).  But such machines will
5559      * not likely have syscall implemented either, so who cares?
5560      */
5561     while (++MARK <= SP) {
5562         if (SvNIOK(*MARK) || !i)
5563             a[i++] = SvIV(*MARK);
5564         else if (*MARK == &PL_sv_undef)
5565             a[i++] = 0;
5566         else
5567             a[i++] = (unsigned long)SvPV_force_nolen(*MARK);
5568         if (i > 15)
5569             break;
5570     }
5571     switch (items) {
5572     default:
5573         DIE(aTHX_ "Too many args to syscall");
5574     case 0:
5575         DIE(aTHX_ "Too few args to syscall");
5576     case 1:
5577         retval = syscall(a[0]);
5578         break;
5579     case 2:
5580         retval = syscall(a[0],a[1]);
5581         break;
5582     case 3:
5583         retval = syscall(a[0],a[1],a[2]);
5584         break;
5585     case 4:
5586         retval = syscall(a[0],a[1],a[2],a[3]);
5587         break;
5588     case 5:
5589         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5590         break;
5591     case 6:
5592         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5593         break;
5594     case 7:
5595         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5596         break;
5597     case 8:
5598         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5599         break;
5600     }
5601     SP = ORIGMARK;
5602     PUSHi(retval);
5603     RETURN;
5604 #else
5605     DIE(aTHX_ PL_no_func, "syscall");
5606 #endif
5607 }
5608
5609 #ifdef FCNTL_EMULATE_FLOCK
5610
5611 /*  XXX Emulate flock() with fcntl().
5612     What's really needed is a good file locking module.
5613 */
5614
5615 static int
5616 fcntl_emulate_flock(int fd, int operation)
5617 {
5618     int res;
5619     struct flock flock;
5620
5621     switch (operation & ~LOCK_NB) {
5622     case LOCK_SH:
5623         flock.l_type = F_RDLCK;
5624         break;
5625     case LOCK_EX:
5626         flock.l_type = F_WRLCK;
5627         break;
5628     case LOCK_UN:
5629         flock.l_type = F_UNLCK;
5630         break;
5631     default:
5632         errno = EINVAL;
5633         return -1;
5634     }
5635     flock.l_whence = SEEK_SET;
5636     flock.l_start = flock.l_len = (Off_t)0;
5637
5638     res = fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5639     if (res == -1 && ((errno == EAGAIN) || (errno == EACCES)))
5640         errno = EWOULDBLOCK;
5641     return res;
5642 }
5643
5644 #endif /* FCNTL_EMULATE_FLOCK */
5645
5646 #ifdef LOCKF_EMULATE_FLOCK
5647
5648 /*  XXX Emulate flock() with lockf().  This is just to increase
5649     portability of scripts.  The calls are not completely
5650     interchangeable.  What's really needed is a good file
5651     locking module.
5652 */
5653
5654 /*  The lockf() constants might have been defined in <unistd.h>.
5655     Unfortunately, <unistd.h> causes troubles on some mixed
5656     (BSD/POSIX) systems, such as SunOS 4.1.3.
5657
5658    Further, the lockf() constants aren't POSIX, so they might not be
5659    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
5660    just stick in the SVID values and be done with it.  Sigh.
5661 */
5662
5663 # ifndef F_ULOCK
5664 #  define F_ULOCK       0       /* Unlock a previously locked region */
5665 # endif
5666 # ifndef F_LOCK
5667 #  define F_LOCK        1       /* Lock a region for exclusive use */
5668 # endif
5669 # ifndef F_TLOCK
5670 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
5671 # endif
5672 # ifndef F_TEST
5673 #  define F_TEST        3       /* Test a region for other processes locks */
5674 # endif
5675
5676 static int
5677 lockf_emulate_flock(int fd, int operation)
5678 {
5679     int i;
5680     Off_t pos;
5681     dSAVE_ERRNO;
5682
5683     /* flock locks entire file so for lockf we need to do the same      */
5684     pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
5685     if (pos > 0)        /* is seekable and needs to be repositioned     */
5686         if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
5687             pos = -1;   /* seek failed, so don't seek back afterwards   */
5688     RESTORE_ERRNO;
5689
5690     switch (operation) {
5691
5692         /* LOCK_SH - get a shared lock */
5693         case LOCK_SH:
5694         /* LOCK_EX - get an exclusive lock */
5695         case LOCK_EX:
5696             i = lockf (fd, F_LOCK, 0);
5697             break;
5698
5699         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5700         case LOCK_SH|LOCK_NB:
5701         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5702         case LOCK_EX|LOCK_NB:
5703             i = lockf (fd, F_TLOCK, 0);
5704             if (i == -1)
5705                 if ((errno == EAGAIN) || (errno == EACCES))
5706                     errno = EWOULDBLOCK;
5707             break;
5708
5709         /* LOCK_UN - unlock (non-blocking is a no-op) */
5710         case LOCK_UN:
5711         case LOCK_UN|LOCK_NB:
5712             i = lockf (fd, F_ULOCK, 0);
5713             break;
5714
5715         /* Default - can't decipher operation */
5716         default:
5717             i = -1;
5718             errno = EINVAL;
5719             break;
5720     }
5721
5722     if (pos > 0)      /* need to restore position of the handle */
5723         PerlLIO_lseek(fd, pos, SEEK_SET);       /* ignore error here    */
5724
5725     return (i);
5726 }
5727
5728 #endif /* LOCKF_EMULATE_FLOCK */
5729
5730 /*
5731  * ex: set ts=8 sts=4 sw=4 et:
5732  */