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