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