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