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