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