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