Skip suid File::Copy tests on a nosuid partition
[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();
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();
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     /* I believe that all these three are likely to be defined on most every
3220        system these days.  */
3221 #ifndef S_ISUID
3222     if(PL_op->op_type == OP_FTSUID)
3223         RETPUSHNO;
3224 #endif
3225 #ifndef S_ISGID
3226     if(PL_op->op_type == OP_FTSGID)
3227         RETPUSHNO;
3228 #endif
3229 #ifndef S_ISVTX
3230     if(PL_op->op_type == OP_FTSVTX)
3231         RETPUSHNO;
3232 #endif
3233
3234     STACKED_FTEST_CHECK;
3235
3236     result = my_stat();
3237     SPAGAIN;
3238     if (result < 0)
3239         RETPUSHUNDEF;
3240     switch (PL_op->op_type) {
3241     case OP_FTROWNED:
3242         if (PL_statcache.st_uid == PL_uid)
3243             RETPUSHYES;
3244         break;
3245     case OP_FTEOWNED:
3246         if (PL_statcache.st_uid == PL_euid)
3247             RETPUSHYES;
3248         break;
3249     case OP_FTZERO:
3250         if (PL_statcache.st_size == 0)
3251             RETPUSHYES;
3252         break;
3253     case OP_FTSOCK:
3254         if (S_ISSOCK(PL_statcache.st_mode))
3255             RETPUSHYES;
3256         break;
3257     case OP_FTCHR:
3258         if (S_ISCHR(PL_statcache.st_mode))
3259             RETPUSHYES;
3260         break;
3261     case OP_FTBLK:
3262         if (S_ISBLK(PL_statcache.st_mode))
3263             RETPUSHYES;
3264         break;
3265     case OP_FTFILE:
3266         if (S_ISREG(PL_statcache.st_mode))
3267             RETPUSHYES;
3268         break;
3269     case OP_FTDIR:
3270         if (S_ISDIR(PL_statcache.st_mode))
3271             RETPUSHYES;
3272         break;
3273     case OP_FTPIPE:
3274         if (S_ISFIFO(PL_statcache.st_mode))
3275             RETPUSHYES;
3276         break;
3277 #ifdef S_ISUID
3278     case OP_FTSUID:
3279         if (PL_statcache.st_mode & S_ISUID)
3280             RETPUSHYES;
3281         break;
3282 #endif
3283 #ifdef S_ISGID
3284     case OP_FTSGID:
3285         if (PL_statcache.st_mode & S_ISGID)
3286             RETPUSHYES;
3287         break;
3288 #endif
3289 #ifdef S_ISVTX
3290     case OP_FTSVTX:
3291         if (PL_statcache.st_mode & S_ISVTX)
3292             RETPUSHYES;
3293         break;
3294 #endif
3295     }
3296     RETPUSHNO;
3297 }
3298
3299 PP(pp_ftlink)
3300 {
3301     dVAR;
3302     dSP;
3303     I32 result;
3304
3305     tryAMAGICftest_MG('l');
3306     result = my_lstat();
3307     SPAGAIN;
3308
3309     if (result < 0)
3310         RETPUSHUNDEF;
3311     if (S_ISLNK(PL_statcache.st_mode))
3312         RETPUSHYES;
3313     RETPUSHNO;
3314 }
3315
3316 PP(pp_fttty)
3317 {
3318     dVAR;
3319     dSP;
3320     int fd;
3321     GV *gv;
3322     SV *tmpsv = NULL;
3323
3324     tryAMAGICftest_MG('t');
3325
3326     STACKED_FTEST_CHECK;
3327
3328     if (PL_op->op_flags & OPf_REF)
3329         gv = cGVOP_gv;
3330     else if (isGV(TOPs))
3331         gv = MUTABLE_GV(POPs);
3332     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3333         gv = MUTABLE_GV(SvRV(POPs));
3334     else
3335         gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3336
3337     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3338         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3339     else if (tmpsv && SvOK(tmpsv)) {
3340         const char *tmps = SvPV_nolen_const(tmpsv);
3341         if (isDIGIT(*tmps))
3342             fd = atoi(tmps);
3343         else 
3344             RETPUSHUNDEF;
3345     }
3346     else
3347         RETPUSHUNDEF;
3348     if (PerlLIO_isatty(fd))
3349         RETPUSHYES;
3350     RETPUSHNO;
3351 }
3352
3353 #if defined(atarist) /* this will work with atariST. Configure will
3354                         make guesses for other systems. */
3355 # define FILE_base(f) ((f)->_base)
3356 # define FILE_ptr(f) ((f)->_ptr)
3357 # define FILE_cnt(f) ((f)->_cnt)
3358 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3359 #endif
3360
3361 PP(pp_fttext)
3362 {
3363     dVAR;
3364     dSP;
3365     I32 i;
3366     I32 len;
3367     I32 odd = 0;
3368     STDCHAR tbuf[512];
3369     register STDCHAR *s;
3370     register IO *io;
3371     register SV *sv;
3372     GV *gv;
3373     PerlIO *fp;
3374
3375     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3376
3377     STACKED_FTEST_CHECK;
3378
3379     if (PL_op->op_flags & OPf_REF)
3380         gv = cGVOP_gv;
3381     else if (isGV(TOPs))
3382         gv = MUTABLE_GV(POPs);
3383     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3384         gv = MUTABLE_GV(SvRV(POPs));
3385     else
3386         gv = NULL;
3387
3388     if (gv) {
3389         EXTEND(SP, 1);
3390         if (gv == PL_defgv) {
3391             if (PL_statgv)
3392                 io = GvIO(PL_statgv);
3393             else {
3394                 sv = PL_statname;
3395                 goto really_filename;
3396             }
3397         }
3398         else {
3399             PL_statgv = gv;
3400             PL_laststatval = -1;
3401             sv_setpvs(PL_statname, "");
3402             io = GvIO(PL_statgv);
3403         }
3404         if (io && IoIFP(io)) {
3405             if (! PerlIO_has_base(IoIFP(io)))
3406                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3407             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3408             if (PL_laststatval < 0)
3409                 RETPUSHUNDEF;
3410             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3411                 if (PL_op->op_type == OP_FTTEXT)
3412                     RETPUSHNO;
3413                 else
3414                     RETPUSHYES;
3415             }
3416             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3417                 i = PerlIO_getc(IoIFP(io));
3418                 if (i != EOF)
3419                     (void)PerlIO_ungetc(IoIFP(io),i);
3420             }
3421             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3422                 RETPUSHYES;
3423             len = PerlIO_get_bufsiz(IoIFP(io));
3424             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3425             /* sfio can have large buffers - limit to 512 */
3426             if (len > 512)
3427                 len = 512;
3428         }
3429         else {
3430             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3431                 gv = cGVOP_gv;
3432                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3433             }
3434             SETERRNO(EBADF,RMS_IFI);
3435             RETPUSHUNDEF;
3436         }
3437     }
3438     else {
3439         sv = POPs;
3440       really_filename:
3441         PL_statgv = NULL;
3442         PL_laststype = OP_STAT;
3443         sv_setpv(PL_statname, SvPV_nolen_const(sv));
3444         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3445             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3446                                                '\n'))
3447                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3448             RETPUSHUNDEF;
3449         }
3450         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3451         if (PL_laststatval < 0) {
3452             (void)PerlIO_close(fp);
3453             RETPUSHUNDEF;
3454         }
3455         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3456         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3457         (void)PerlIO_close(fp);
3458         if (len <= 0) {
3459             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3460                 RETPUSHNO;              /* special case NFS directories */
3461             RETPUSHYES;         /* null file is anything */
3462         }
3463         s = tbuf;
3464     }
3465
3466     /* now scan s to look for textiness */
3467     /*   XXX ASCII dependent code */
3468
3469 #if defined(DOSISH) || defined(USEMYBINMODE)
3470     /* ignore trailing ^Z on short files */
3471     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3472         --len;
3473 #endif
3474
3475     for (i = 0; i < len; i++, s++) {
3476         if (!*s) {                      /* null never allowed in text */
3477             odd += len;
3478             break;
3479         }
3480 #ifdef EBCDIC
3481         else if (!(isPRINT(*s) || isSPACE(*s)))
3482             odd++;
3483 #else
3484         else if (*s & 128) {
3485 #ifdef USE_LOCALE
3486             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3487                 continue;
3488 #endif
3489             /* utf8 characters don't count as odd */
3490             if (UTF8_IS_START(*s)) {
3491                 int ulen = UTF8SKIP(s);
3492                 if (ulen < len - i) {
3493                     int j;
3494                     for (j = 1; j < ulen; j++) {
3495                         if (!UTF8_IS_CONTINUATION(s[j]))
3496                             goto not_utf8;
3497                     }
3498                     --ulen;     /* loop does extra increment */
3499                     s += ulen;
3500                     i += ulen;
3501                     continue;
3502                 }
3503             }
3504           not_utf8:
3505             odd++;
3506         }
3507         else if (*s < 32 &&
3508           *s != '\n' && *s != '\r' && *s != '\b' &&
3509           *s != '\t' && *s != '\f' && *s != 27)
3510             odd++;
3511 #endif
3512     }
3513
3514     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3515         RETPUSHNO;
3516     else
3517         RETPUSHYES;
3518 }
3519
3520 /* File calls. */
3521
3522 PP(pp_chdir)
3523 {
3524     dVAR; dSP; dTARGET;
3525     const char *tmps = NULL;
3526     GV *gv = NULL;
3527
3528     if( MAXARG == 1 ) {
3529         SV * const sv = POPs;
3530         if (PL_op->op_flags & OPf_SPECIAL) {
3531             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3532         }
3533         else if (isGV_with_GP(sv)) {
3534             gv = MUTABLE_GV(sv);
3535         }
3536         else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3537             gv = MUTABLE_GV(SvRV(sv));
3538         }
3539         else {
3540             tmps = SvPV_nolen_const(sv);
3541         }
3542     }
3543
3544     if( !gv && (!tmps || !*tmps) ) {
3545         HV * const table = GvHVn(PL_envgv);
3546         SV **svp;
3547
3548         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3549              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3550 #ifdef VMS
3551              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3552 #endif
3553            )
3554         {
3555             if( MAXARG == 1 )
3556                 deprecate("chdir('') or chdir(undef) as chdir()");
3557             tmps = SvPV_nolen_const(*svp);
3558         }
3559         else {
3560             PUSHi(0);
3561             TAINT_PROPER("chdir");
3562             RETURN;
3563         }
3564     }
3565
3566     TAINT_PROPER("chdir");
3567     if (gv) {
3568 #ifdef HAS_FCHDIR
3569         IO* const io = GvIO(gv);
3570         if (io) {
3571             if (IoDIRP(io)) {
3572                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3573             } else if (IoIFP(io)) {
3574                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3575             }
3576             else {
3577                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3578                     report_evil_fh(gv, io, PL_op->op_type);
3579                 SETERRNO(EBADF, RMS_IFI);
3580                 PUSHi(0);
3581             }
3582         }
3583         else {
3584             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3585                 report_evil_fh(gv, io, PL_op->op_type);
3586             SETERRNO(EBADF,RMS_IFI);
3587             PUSHi(0);
3588         }
3589 #else
3590         DIE(aTHX_ PL_no_func, "fchdir");
3591 #endif
3592     }
3593     else 
3594         PUSHi( PerlDir_chdir(tmps) >= 0 );
3595 #ifdef VMS
3596     /* Clear the DEFAULT element of ENV so we'll get the new value
3597      * in the future. */
3598     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3599 #endif
3600     RETURN;
3601 }
3602
3603 PP(pp_chown)
3604 {
3605     dVAR; dSP; dMARK; dTARGET;
3606     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3607
3608     SP = MARK;
3609     XPUSHi(value);
3610     RETURN;
3611 }
3612
3613 PP(pp_chroot)
3614 {
3615 #ifdef HAS_CHROOT
3616     dVAR; dSP; dTARGET;
3617     char * const tmps = POPpx;
3618     TAINT_PROPER("chroot");
3619     PUSHi( chroot(tmps) >= 0 );
3620     RETURN;
3621 #else
3622     DIE(aTHX_ PL_no_func, "chroot");
3623 #endif
3624 }
3625
3626 PP(pp_rename)
3627 {
3628     dVAR; dSP; dTARGET;
3629     int anum;
3630     const char * const tmps2 = POPpconstx;
3631     const char * const tmps = SvPV_nolen_const(TOPs);
3632     TAINT_PROPER("rename");
3633 #ifdef HAS_RENAME
3634     anum = PerlLIO_rename(tmps, tmps2);
3635 #else
3636     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3637         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3638             anum = 1;
3639         else {
3640             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3641                 (void)UNLINK(tmps2);
3642             if (!(anum = link(tmps, tmps2)))
3643                 anum = UNLINK(tmps);
3644         }
3645     }
3646 #endif
3647     SETi( anum >= 0 );
3648     RETURN;
3649 }
3650
3651 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3652 PP(pp_link)
3653 {
3654     dVAR; dSP; dTARGET;
3655     const int op_type = PL_op->op_type;
3656     int result;
3657
3658 #  ifndef HAS_LINK
3659     if (op_type == OP_LINK)
3660         DIE(aTHX_ PL_no_func, "link");
3661 #  endif
3662 #  ifndef HAS_SYMLINK
3663     if (op_type == OP_SYMLINK)
3664         DIE(aTHX_ PL_no_func, "symlink");
3665 #  endif
3666
3667     {
3668         const char * const tmps2 = POPpconstx;
3669         const char * const tmps = SvPV_nolen_const(TOPs);
3670         TAINT_PROPER(PL_op_desc[op_type]);
3671         result =
3672 #  if defined(HAS_LINK)
3673 #    if defined(HAS_SYMLINK)
3674             /* Both present - need to choose which.  */
3675             (op_type == OP_LINK) ?
3676             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3677 #    else
3678     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3679         PerlLIO_link(tmps, tmps2);
3680 #    endif
3681 #  else
3682 #    if defined(HAS_SYMLINK)
3683     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3684         symlink(tmps, tmps2);
3685 #    endif
3686 #  endif
3687     }
3688
3689     SETi( result >= 0 );
3690     RETURN;
3691 }
3692 #else
3693 PP(pp_link)
3694 {
3695     /* Have neither.  */
3696     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3697 }
3698 #endif
3699
3700 PP(pp_readlink)
3701 {
3702     dVAR;
3703     dSP;
3704 #ifdef HAS_SYMLINK
3705     dTARGET;
3706     const char *tmps;
3707     char buf[MAXPATHLEN];
3708     int len;
3709
3710 #ifndef INCOMPLETE_TAINTS
3711     TAINT;
3712 #endif
3713     tmps = POPpconstx;
3714     len = readlink(tmps, buf, sizeof(buf) - 1);
3715     if (len < 0)
3716         RETPUSHUNDEF;
3717     PUSHp(buf, len);
3718     RETURN;
3719 #else
3720     EXTEND(SP, 1);
3721     RETSETUNDEF;                /* just pretend it's a normal file */
3722 #endif
3723 }
3724
3725 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3726 STATIC int
3727 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3728 {
3729     char * const save_filename = filename;
3730     char *cmdline;
3731     char *s;
3732     PerlIO *myfp;
3733     int anum = 1;
3734     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3735
3736     PERL_ARGS_ASSERT_DOONELINER;
3737
3738     Newx(cmdline, size, char);
3739     my_strlcpy(cmdline, cmd, size);
3740     my_strlcat(cmdline, " ", size);
3741     for (s = cmdline + strlen(cmdline); *filename; ) {
3742         *s++ = '\\';
3743         *s++ = *filename++;
3744     }
3745     if (s - cmdline < size)
3746         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3747     myfp = PerlProc_popen(cmdline, "r");
3748     Safefree(cmdline);
3749
3750     if (myfp) {
3751         SV * const tmpsv = sv_newmortal();
3752         /* Need to save/restore 'PL_rs' ?? */
3753         s = sv_gets(tmpsv, myfp, 0);
3754         (void)PerlProc_pclose(myfp);
3755         if (s != NULL) {
3756             int e;
3757             for (e = 1;
3758 #ifdef HAS_SYS_ERRLIST
3759                  e <= sys_nerr
3760 #endif
3761                  ; e++)
3762             {
3763                 /* you don't see this */
3764                 const char * const errmsg =
3765 #ifdef HAS_SYS_ERRLIST
3766                     sys_errlist[e]
3767 #else
3768                     strerror(e)
3769 #endif
3770                     ;
3771                 if (!errmsg)
3772                     break;
3773                 if (instr(s, errmsg)) {
3774                     SETERRNO(e,0);
3775                     return 0;
3776                 }
3777             }
3778             SETERRNO(0,0);
3779 #ifndef EACCES
3780 #define EACCES EPERM
3781 #endif
3782             if (instr(s, "cannot make"))
3783                 SETERRNO(EEXIST,RMS_FEX);
3784             else if (instr(s, "existing file"))
3785                 SETERRNO(EEXIST,RMS_FEX);
3786             else if (instr(s, "ile exists"))
3787                 SETERRNO(EEXIST,RMS_FEX);
3788             else if (instr(s, "non-exist"))
3789                 SETERRNO(ENOENT,RMS_FNF);
3790             else if (instr(s, "does not exist"))
3791                 SETERRNO(ENOENT,RMS_FNF);
3792             else if (instr(s, "not empty"))
3793                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3794             else if (instr(s, "cannot access"))
3795                 SETERRNO(EACCES,RMS_PRV);
3796             else
3797                 SETERRNO(EPERM,RMS_PRV);
3798             return 0;
3799         }
3800         else {  /* some mkdirs return no failure indication */
3801             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3802             if (PL_op->op_type == OP_RMDIR)
3803                 anum = !anum;
3804             if (anum)
3805                 SETERRNO(0,0);
3806             else
3807                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3808         }
3809         return anum;
3810     }
3811     else
3812         return 0;
3813 }
3814 #endif
3815
3816 /* This macro removes trailing slashes from a directory name.
3817  * Different operating and file systems take differently to
3818  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3819  * any number of trailing slashes should be allowed.
3820  * Thusly we snip them away so that even non-conforming
3821  * systems are happy.
3822  * We should probably do this "filtering" for all
3823  * the functions that expect (potentially) directory names:
3824  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3825  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3826
3827 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3828     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3829         do { \
3830             (len)--; \
3831         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3832         (tmps) = savepvn((tmps), (len)); \
3833         (copy) = TRUE; \
3834     }
3835
3836 PP(pp_mkdir)
3837 {
3838     dVAR; dSP; dTARGET;
3839     STRLEN len;
3840     const char *tmps;
3841     bool copy = FALSE;
3842     const int mode = (MAXARG > 1) ? POPi : 0777;
3843
3844     TRIMSLASHES(tmps,len,copy);
3845
3846     TAINT_PROPER("mkdir");
3847 #ifdef HAS_MKDIR
3848     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3849 #else
3850     {
3851     int oldumask;
3852     SETi( dooneliner("mkdir", tmps) );
3853     oldumask = PerlLIO_umask(0);
3854     PerlLIO_umask(oldumask);
3855     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3856     }
3857 #endif
3858     if (copy)
3859         Safefree(tmps);
3860     RETURN;
3861 }
3862
3863 PP(pp_rmdir)
3864 {
3865     dVAR; dSP; dTARGET;
3866     STRLEN len;
3867     const char *tmps;
3868     bool copy = FALSE;
3869
3870     TRIMSLASHES(tmps,len,copy);
3871     TAINT_PROPER("rmdir");
3872 #ifdef HAS_RMDIR
3873     SETi( PerlDir_rmdir(tmps) >= 0 );
3874 #else
3875     SETi( dooneliner("rmdir", tmps) );
3876 #endif
3877     if (copy)
3878         Safefree(tmps);
3879     RETURN;
3880 }
3881
3882 /* Directory calls. */
3883
3884 PP(pp_open_dir)
3885 {
3886 #if defined(Direntry_t) && defined(HAS_READDIR)
3887     dVAR; dSP;
3888     const char * const dirname = POPpconstx;
3889     GV * const gv = MUTABLE_GV(POPs);
3890     register IO * const io = GvIOn(gv);
3891
3892     if (!io)
3893         goto nope;
3894
3895     if ((IoIFP(io) || IoOFP(io)))
3896         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3897                          "Opening filehandle %s also as a directory",
3898                          GvENAME(gv));
3899     if (IoDIRP(io))
3900         PerlDir_close(IoDIRP(io));
3901     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3902         goto nope;
3903
3904     RETPUSHYES;
3905 nope:
3906     if (!errno)
3907         SETERRNO(EBADF,RMS_DIR);
3908     RETPUSHUNDEF;
3909 #else
3910     DIE(aTHX_ PL_no_dir_func, "opendir");
3911 #endif
3912 }
3913
3914 PP(pp_readdir)
3915 {
3916 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3917     DIE(aTHX_ PL_no_dir_func, "readdir");
3918 #else
3919 #if !defined(I_DIRENT) && !defined(VMS)
3920     Direntry_t *readdir (DIR *);
3921 #endif
3922     dVAR;
3923     dSP;
3924
3925     SV *sv;
3926     const I32 gimme = GIMME;
3927     GV * const gv = MUTABLE_GV(POPs);
3928     register const Direntry_t *dp;
3929     register IO * const io = GvIOn(gv);
3930
3931     if (!io || !IoDIRP(io)) {
3932         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3933                        "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3934         goto nope;
3935     }
3936
3937     do {
3938         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3939         if (!dp)
3940             break;
3941 #ifdef DIRNAMLEN
3942         sv = newSVpvn(dp->d_name, dp->d_namlen);
3943 #else
3944         sv = newSVpv(dp->d_name, 0);
3945 #endif
3946 #ifndef INCOMPLETE_TAINTS
3947         if (!(IoFLAGS(io) & IOf_UNTAINT))
3948             SvTAINTED_on(sv);
3949 #endif
3950         mXPUSHs(sv);
3951     } while (gimme == G_ARRAY);
3952
3953     if (!dp && gimme != G_ARRAY)
3954         goto nope;
3955
3956     RETURN;
3957
3958 nope:
3959     if (!errno)
3960         SETERRNO(EBADF,RMS_ISI);
3961     if (GIMME == G_ARRAY)
3962         RETURN;
3963     else
3964         RETPUSHUNDEF;
3965 #endif
3966 }
3967
3968 PP(pp_telldir)
3969 {
3970 #if defined(HAS_TELLDIR) || defined(telldir)
3971     dVAR; dSP; dTARGET;
3972  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3973  /* XXX netbsd still seemed to.
3974     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3975     --JHI 1999-Feb-02 */
3976 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3977     long telldir (DIR *);
3978 # endif
3979     GV * const gv = MUTABLE_GV(POPs);
3980     register IO * const io = GvIOn(gv);
3981
3982     if (!io || !IoDIRP(io)) {
3983         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3984                        "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3985         goto nope;
3986     }
3987
3988     PUSHi( PerlDir_tell(IoDIRP(io)) );
3989     RETURN;
3990 nope:
3991     if (!errno)
3992         SETERRNO(EBADF,RMS_ISI);
3993     RETPUSHUNDEF;
3994 #else
3995     DIE(aTHX_ PL_no_dir_func, "telldir");
3996 #endif
3997 }
3998
3999 PP(pp_seekdir)
4000 {
4001 #if defined(HAS_SEEKDIR) || defined(seekdir)
4002     dVAR; dSP;
4003     const long along = POPl;
4004     GV * const gv = MUTABLE_GV(POPs);
4005     register IO * const io = GvIOn(gv);
4006
4007     if (!io || !IoDIRP(io)) {
4008         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4009                        "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4010         goto nope;
4011     }
4012     (void)PerlDir_seek(IoDIRP(io), along);
4013
4014     RETPUSHYES;
4015 nope:
4016     if (!errno)
4017         SETERRNO(EBADF,RMS_ISI);
4018     RETPUSHUNDEF;
4019 #else
4020     DIE(aTHX_ PL_no_dir_func, "seekdir");
4021 #endif
4022 }
4023
4024 PP(pp_rewinddir)
4025 {
4026 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4027     dVAR; dSP;
4028     GV * const gv = MUTABLE_GV(POPs);
4029     register IO * const io = GvIOn(gv);
4030
4031     if (!io || !IoDIRP(io)) {
4032         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4033                        "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4034         goto nope;
4035     }
4036     (void)PerlDir_rewind(IoDIRP(io));
4037     RETPUSHYES;
4038 nope:
4039     if (!errno)
4040         SETERRNO(EBADF,RMS_ISI);
4041     RETPUSHUNDEF;
4042 #else
4043     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4044 #endif
4045 }
4046
4047 PP(pp_closedir)
4048 {
4049 #if defined(Direntry_t) && defined(HAS_READDIR)
4050     dVAR; dSP;
4051     GV * const gv = MUTABLE_GV(POPs);
4052     register IO * const io = GvIOn(gv);
4053
4054     if (!io || !IoDIRP(io)) {
4055         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4056                        "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4057         goto nope;
4058     }
4059 #ifdef VOID_CLOSEDIR
4060     PerlDir_close(IoDIRP(io));
4061 #else
4062     if (PerlDir_close(IoDIRP(io)) < 0) {
4063         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4064         goto nope;
4065     }
4066 #endif
4067     IoDIRP(io) = 0;
4068
4069     RETPUSHYES;
4070 nope:
4071     if (!errno)
4072         SETERRNO(EBADF,RMS_IFI);
4073     RETPUSHUNDEF;
4074 #else
4075     DIE(aTHX_ PL_no_dir_func, "closedir");
4076 #endif
4077 }
4078
4079 /* Process control. */
4080
4081 PP(pp_fork)
4082 {
4083 #ifdef HAS_FORK
4084     dVAR; dSP; dTARGET;
4085     Pid_t childpid;
4086
4087     EXTEND(SP, 1);
4088     PERL_FLUSHALL_FOR_CHILD;
4089     childpid = PerlProc_fork();
4090     if (childpid < 0)
4091         RETSETUNDEF;
4092     if (!childpid) {
4093         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4094         if (tmpgv) {
4095             SvREADONLY_off(GvSV(tmpgv));
4096             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4097             SvREADONLY_on(GvSV(tmpgv));
4098         }
4099 #ifdef THREADS_HAVE_PIDS
4100         PL_ppid = (IV)getppid();
4101 #endif
4102 #ifdef PERL_USES_PL_PIDSTATUS
4103         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4104 #endif
4105     }
4106     PUSHi(childpid);
4107     RETURN;
4108 #else
4109 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4110     dSP; dTARGET;
4111     Pid_t childpid;
4112
4113     EXTEND(SP, 1);
4114     PERL_FLUSHALL_FOR_CHILD;
4115     childpid = PerlProc_fork();
4116     if (childpid == -1)
4117         RETSETUNDEF;
4118     PUSHi(childpid);
4119     RETURN;
4120 #  else
4121     DIE(aTHX_ PL_no_func, "fork");
4122 #  endif
4123 #endif
4124 }
4125
4126 PP(pp_wait)
4127 {
4128 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4129     dVAR; dSP; dTARGET;
4130     Pid_t childpid;
4131     int argflags;
4132
4133     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4134         childpid = wait4pid(-1, &argflags, 0);
4135     else {
4136         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4137                errno == EINTR) {
4138           PERL_ASYNC_CHECK();
4139         }
4140     }
4141 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4142     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4143     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4144 #  else
4145     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4146 #  endif
4147     XPUSHi(childpid);
4148     RETURN;
4149 #else
4150     DIE(aTHX_ PL_no_func, "wait");
4151 #endif
4152 }
4153
4154 PP(pp_waitpid)
4155 {
4156 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4157     dVAR; dSP; dTARGET;
4158     const int optype = POPi;
4159     const Pid_t pid = TOPi;
4160     Pid_t result;
4161     int argflags;
4162
4163     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4164         result = wait4pid(pid, &argflags, optype);
4165     else {
4166         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4167                errno == EINTR) {
4168           PERL_ASYNC_CHECK();
4169         }
4170     }
4171 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4172     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4173     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4174 #  else
4175     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4176 #  endif
4177     SETi(result);
4178     RETURN;
4179 #else
4180     DIE(aTHX_ PL_no_func, "waitpid");
4181 #endif
4182 }
4183
4184 PP(pp_system)
4185 {
4186     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4187 #if defined(__LIBCATAMOUNT__)
4188     PL_statusvalue = -1;
4189     SP = ORIGMARK;
4190     XPUSHi(-1);
4191 #else
4192     I32 value;
4193     int result;
4194
4195     if (PL_tainting) {
4196         TAINT_ENV();
4197         while (++MARK <= SP) {
4198             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4199             if (PL_tainted)
4200                 break;
4201         }
4202         MARK = ORIGMARK;
4203         TAINT_PROPER("system");
4204     }
4205     PERL_FLUSHALL_FOR_CHILD;
4206 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4207     {
4208         Pid_t childpid;
4209         int pp[2];
4210         I32 did_pipes = 0;
4211
4212         if (PerlProc_pipe(pp) >= 0)
4213             did_pipes = 1;
4214         while ((childpid = PerlProc_fork()) == -1) {
4215             if (errno != EAGAIN) {
4216                 value = -1;
4217                 SP = ORIGMARK;
4218                 XPUSHi(value);
4219                 if (did_pipes) {
4220                     PerlLIO_close(pp[0]);
4221                     PerlLIO_close(pp[1]);
4222                 }
4223                 RETURN;
4224             }
4225             sleep(5);
4226         }
4227         if (childpid > 0) {
4228             Sigsave_t ihand,qhand; /* place to save signals during system() */
4229             int status;
4230
4231             if (did_pipes)
4232                 PerlLIO_close(pp[1]);
4233 #ifndef PERL_MICRO
4234             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4235             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4236 #endif
4237             do {
4238                 result = wait4pid(childpid, &status, 0);
4239             } while (result == -1 && errno == EINTR);
4240 #ifndef PERL_MICRO
4241             (void)rsignal_restore(SIGINT, &ihand);
4242             (void)rsignal_restore(SIGQUIT, &qhand);
4243 #endif
4244             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4245             do_execfree();      /* free any memory child malloced on fork */
4246             SP = ORIGMARK;
4247             if (did_pipes) {
4248                 int errkid;
4249                 unsigned n = 0;
4250                 SSize_t n1;
4251
4252                 while (n < sizeof(int)) {
4253                     n1 = PerlLIO_read(pp[0],
4254                                       (void*)(((char*)&errkid)+n),
4255                                       (sizeof(int)) - n);
4256                     if (n1 <= 0)
4257                         break;
4258                     n += n1;
4259                 }
4260                 PerlLIO_close(pp[0]);
4261                 if (n) {                        /* Error */
4262                     if (n != sizeof(int))
4263                         DIE(aTHX_ "panic: kid popen errno read");
4264                     errno = errkid;             /* Propagate errno from kid */
4265                     STATUS_NATIVE_CHILD_SET(-1);
4266                 }
4267             }
4268             XPUSHi(STATUS_CURRENT);
4269             RETURN;
4270         }
4271         if (did_pipes) {
4272             PerlLIO_close(pp[0]);
4273 #if defined(HAS_FCNTL) && defined(F_SETFD)
4274             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4275 #endif
4276         }
4277         if (PL_op->op_flags & OPf_STACKED) {
4278             SV * const really = *++MARK;
4279             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4280         }
4281         else if (SP - MARK != 1)
4282             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4283         else {
4284             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4285         }
4286         PerlProc__exit(-1);
4287     }
4288 #else /* ! FORK or VMS or OS/2 */
4289     PL_statusvalue = 0;
4290     result = 0;
4291     if (PL_op->op_flags & OPf_STACKED) {
4292         SV * const really = *++MARK;
4293 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4294         value = (I32)do_aspawn(really, MARK, SP);
4295 #  else
4296         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4297 #  endif
4298     }
4299     else if (SP - MARK != 1) {
4300 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4301         value = (I32)do_aspawn(NULL, MARK, SP);
4302 #  else
4303         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4304 #  endif
4305     }
4306     else {
4307         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4308     }
4309     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4310         result = 1;
4311     STATUS_NATIVE_CHILD_SET(value);
4312     do_execfree();
4313     SP = ORIGMARK;
4314     XPUSHi(result ? value : STATUS_CURRENT);
4315 #endif /* !FORK or VMS or OS/2 */
4316 #endif
4317     RETURN;
4318 }
4319
4320 PP(pp_exec)
4321 {
4322     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4323     I32 value;
4324
4325     if (PL_tainting) {
4326         TAINT_ENV();
4327         while (++MARK <= SP) {
4328             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4329             if (PL_tainted)
4330                 break;
4331         }
4332         MARK = ORIGMARK;
4333         TAINT_PROPER("exec");
4334     }
4335     PERL_FLUSHALL_FOR_CHILD;
4336     if (PL_op->op_flags & OPf_STACKED) {
4337         SV * const really = *++MARK;
4338         value = (I32)do_aexec(really, MARK, SP);
4339     }
4340     else if (SP - MARK != 1)
4341 #ifdef VMS
4342         value = (I32)vms_do_aexec(NULL, MARK, SP);
4343 #else
4344 #  ifdef __OPEN_VM
4345         {
4346            (void ) do_aspawn(NULL, MARK, SP);
4347            value = 0;
4348         }
4349 #  else
4350         value = (I32)do_aexec(NULL, MARK, SP);
4351 #  endif
4352 #endif
4353     else {
4354 #ifdef VMS
4355         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4356 #else
4357 #  ifdef __OPEN_VM
4358         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4359         value = 0;
4360 #  else
4361         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4362 #  endif
4363 #endif
4364     }
4365
4366     SP = ORIGMARK;
4367     XPUSHi(value);
4368     RETURN;
4369 }
4370
4371 PP(pp_getppid)
4372 {
4373 #ifdef HAS_GETPPID
4374     dVAR; dSP; dTARGET;
4375 #   ifdef THREADS_HAVE_PIDS
4376     if (PL_ppid != 1 && getppid() == 1)
4377         /* maybe the parent process has died. Refresh ppid cache */
4378         PL_ppid = 1;
4379     XPUSHi( PL_ppid );
4380 #   else
4381     XPUSHi( getppid() );
4382 #   endif
4383     RETURN;
4384 #else
4385     DIE(aTHX_ PL_no_func, "getppid");
4386 #endif
4387 }
4388
4389 PP(pp_getpgrp)
4390 {
4391 #ifdef HAS_GETPGRP
4392     dVAR; dSP; dTARGET;
4393     Pid_t pgrp;
4394     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4395
4396 #ifdef BSD_GETPGRP
4397     pgrp = (I32)BSD_GETPGRP(pid);
4398 #else
4399     if (pid != 0 && pid != PerlProc_getpid())
4400         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4401     pgrp = getpgrp();
4402 #endif
4403     XPUSHi(pgrp);
4404     RETURN;
4405 #else
4406     DIE(aTHX_ PL_no_func, "getpgrp()");
4407 #endif
4408 }
4409
4410 PP(pp_setpgrp)
4411 {
4412 #ifdef HAS_SETPGRP
4413     dVAR; dSP; dTARGET;
4414     Pid_t pgrp;
4415     Pid_t pid;
4416     if (MAXARG < 2) {
4417         pgrp = 0;
4418         pid = 0;
4419         XPUSHi(-1);
4420     }
4421     else {
4422         pgrp = POPi;
4423         pid = TOPi;
4424     }
4425
4426     TAINT_PROPER("setpgrp");
4427 #ifdef BSD_SETPGRP
4428     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4429 #else
4430     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4431         || (pid != 0 && pid != PerlProc_getpid()))
4432     {
4433         DIE(aTHX_ "setpgrp can't take arguments");
4434     }
4435     SETi( setpgrp() >= 0 );
4436 #endif /* USE_BSDPGRP */
4437     RETURN;
4438 #else
4439     DIE(aTHX_ PL_no_func, "setpgrp()");
4440 #endif
4441 }
4442
4443 PP(pp_getpriority)
4444 {
4445 #ifdef HAS_GETPRIORITY
4446     dVAR; dSP; dTARGET;
4447     const int who = POPi;
4448     const int which = TOPi;
4449     SETi( getpriority(which, who) );
4450     RETURN;
4451 #else
4452     DIE(aTHX_ PL_no_func, "getpriority()");
4453 #endif
4454 }
4455
4456 PP(pp_setpriority)
4457 {
4458 #ifdef HAS_SETPRIORITY
4459     dVAR; dSP; dTARGET;
4460     const int niceval = POPi;
4461     const int who = POPi;
4462     const int which = TOPi;
4463     TAINT_PROPER("setpriority");
4464     SETi( setpriority(which, who, niceval) >= 0 );
4465     RETURN;
4466 #else
4467     DIE(aTHX_ PL_no_func, "setpriority()");
4468 #endif
4469 }
4470
4471 /* Time calls. */
4472
4473 PP(pp_time)
4474 {
4475     dVAR; dSP; dTARGET;
4476 #ifdef BIG_TIME
4477     XPUSHn( time(NULL) );
4478 #else
4479     XPUSHi( time(NULL) );
4480 #endif
4481     RETURN;
4482 }
4483
4484 PP(pp_tms)
4485 {
4486 #ifdef HAS_TIMES
4487     dVAR;
4488     dSP;
4489     EXTEND(SP, 4);
4490 #ifndef VMS
4491     (void)PerlProc_times(&PL_timesbuf);
4492 #else
4493     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4494                                                    /* struct tms, though same data   */
4495                                                    /* is returned.                   */
4496 #endif
4497
4498     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4499     if (GIMME == G_ARRAY) {
4500         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4501         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4502         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4503     }
4504     RETURN;
4505 #else
4506 #   ifdef PERL_MICRO
4507     dSP;
4508     mPUSHn(0.0);
4509     EXTEND(SP, 4);
4510     if (GIMME == G_ARRAY) {
4511          mPUSHn(0.0);
4512          mPUSHn(0.0);
4513          mPUSHn(0.0);
4514     }
4515     RETURN;
4516 #   else
4517     DIE(aTHX_ "times not implemented");
4518 #   endif
4519 #endif /* HAS_TIMES */
4520 }
4521
4522 /* The 32 bit int year limits the times we can represent to these
4523    boundaries with a few days wiggle room to account for time zone
4524    offsets
4525 */
4526 /* Sat Jan  3 00:00:00 -2147481748 */
4527 #define TIME_LOWER_BOUND -67768100567755200.0
4528 /* Sun Dec 29 12:00:00  2147483647 */
4529 #define TIME_UPPER_BOUND  67767976233316800.0
4530
4531 PP(pp_gmtime)
4532 {
4533     dVAR;
4534     dSP;
4535     Time64_T when;
4536     struct TM tmbuf;
4537     struct TM *err;
4538     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4539     static const char * const dayname[] =
4540         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4541     static const char * const monname[] =
4542         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4543          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4544
4545     if (MAXARG < 1) {
4546         time_t now;
4547         (void)time(&now);
4548         when = (Time64_T)now;
4549     }
4550     else {
4551         NV input = Perl_floor(POPn);
4552         when = (Time64_T)input;
4553         if (when != input) {
4554             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4555                            "%s(%.0" NVff ") too large", opname, input);
4556         }
4557     }
4558
4559     if ( TIME_LOWER_BOUND > when ) {
4560         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4561                        "%s(%.0" NVff ") too small", opname, when);
4562         err = NULL;
4563     }
4564     else if( when > TIME_UPPER_BOUND ) {
4565         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4566                        "%s(%.0" NVff ") too large", opname, when);
4567         err = NULL;
4568     }
4569     else {
4570         if (PL_op->op_type == OP_LOCALTIME)
4571             err = S_localtime64_r(&when, &tmbuf);
4572         else
4573             err = S_gmtime64_r(&when, &tmbuf);
4574     }
4575
4576     if (err == NULL) {
4577         /* XXX %lld broken for quads */
4578         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4579                        "%s(%.0" NVff ") failed", opname, when);
4580     }
4581
4582     if (GIMME != G_ARRAY) {     /* scalar context */
4583         SV *tsv;
4584         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4585         double year = (double)tmbuf.tm_year + 1900;
4586
4587         EXTEND(SP, 1);
4588         EXTEND_MORTAL(1);
4589         if (err == NULL)
4590             RETPUSHUNDEF;
4591
4592         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4593                             dayname[tmbuf.tm_wday],
4594                             monname[tmbuf.tm_mon],
4595                             tmbuf.tm_mday,
4596                             tmbuf.tm_hour,
4597                             tmbuf.tm_min,
4598                             tmbuf.tm_sec,
4599                             year);
4600         mPUSHs(tsv);
4601     }
4602     else {                      /* list context */
4603         if ( err == NULL )
4604             RETURN;
4605
4606         EXTEND(SP, 9);
4607         EXTEND_MORTAL(9);
4608         mPUSHi(tmbuf.tm_sec);
4609         mPUSHi(tmbuf.tm_min);
4610         mPUSHi(tmbuf.tm_hour);
4611         mPUSHi(tmbuf.tm_mday);
4612         mPUSHi(tmbuf.tm_mon);
4613         mPUSHn(tmbuf.tm_year);
4614         mPUSHi(tmbuf.tm_wday);
4615         mPUSHi(tmbuf.tm_yday);
4616         mPUSHi(tmbuf.tm_isdst);
4617     }
4618     RETURN;
4619 }
4620
4621 PP(pp_alarm)
4622 {
4623 #ifdef HAS_ALARM
4624     dVAR; dSP; dTARGET;
4625     int anum;
4626     anum = POPi;
4627     anum = alarm((unsigned int)anum);
4628     if (anum < 0)
4629         RETPUSHUNDEF;
4630     PUSHi(anum);
4631     RETURN;
4632 #else
4633     DIE(aTHX_ PL_no_func, "alarm");
4634 #endif
4635 }
4636
4637 PP(pp_sleep)
4638 {
4639     dVAR; dSP; dTARGET;
4640     I32 duration;
4641     Time_t lasttime;
4642     Time_t when;
4643
4644     (void)time(&lasttime);
4645     if (MAXARG < 1)
4646         PerlProc_pause();
4647     else {
4648         duration = POPi;
4649         PerlProc_sleep((unsigned int)duration);
4650     }
4651     (void)time(&when);
4652     XPUSHi(when - lasttime);
4653     RETURN;
4654 }
4655
4656 /* Shared memory. */
4657 /* Merged with some message passing. */
4658
4659 PP(pp_shmwrite)
4660 {
4661 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4662     dVAR; dSP; dMARK; dTARGET;
4663     const int op_type = PL_op->op_type;
4664     I32 value;
4665
4666     switch (op_type) {
4667     case OP_MSGSND:
4668         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4669         break;
4670     case OP_MSGRCV:
4671         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4672         break;
4673     case OP_SEMOP:
4674         value = (I32)(do_semop(MARK, SP) >= 0);
4675         break;
4676     default:
4677         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4678         break;
4679     }
4680
4681     SP = MARK;
4682     PUSHi(value);
4683     RETURN;
4684 #else
4685     return pp_semget();
4686 #endif
4687 }
4688
4689 /* Semaphores. */
4690
4691 PP(pp_semget)
4692 {
4693 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4694     dVAR; dSP; dMARK; dTARGET;
4695     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4696     SP = MARK;
4697     if (anum == -1)
4698         RETPUSHUNDEF;
4699     PUSHi(anum);
4700     RETURN;
4701 #else
4702     DIE(aTHX_ "System V IPC is not implemented on this machine");
4703 #endif
4704 }
4705
4706 PP(pp_semctl)
4707 {
4708 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4709     dVAR; dSP; dMARK; dTARGET;
4710     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4711     SP = MARK;
4712     if (anum == -1)
4713         RETSETUNDEF;
4714     if (anum != 0) {
4715         PUSHi(anum);
4716     }
4717     else {
4718         PUSHp(zero_but_true, ZBTLEN);
4719     }
4720     RETURN;
4721 #else
4722     return pp_semget();
4723 #endif
4724 }
4725
4726 /* I can't const this further without getting warnings about the types of
4727    various arrays passed in from structures.  */
4728 static SV *
4729 S_space_join_names_mortal(pTHX_ char *const *array)
4730 {
4731     SV *target;
4732
4733     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4734
4735     if (array && *array) {
4736         target = newSVpvs_flags("", SVs_TEMP);
4737         while (1) {
4738             sv_catpv(target, *array);
4739             if (!*++array)
4740                 break;
4741             sv_catpvs(target, " ");
4742         }
4743     } else {
4744         target = sv_mortalcopy(&PL_sv_no);
4745     }
4746     return target;
4747 }
4748
4749 /* Get system info. */
4750
4751 PP(pp_ghostent)
4752 {
4753 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4754     dVAR; dSP;
4755     I32 which = PL_op->op_type;
4756     register char **elem;
4757     register SV *sv;
4758 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4759     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4760     struct hostent *gethostbyname(Netdb_name_t);
4761     struct hostent *gethostent(void);
4762 #endif
4763     struct hostent *hent = NULL;
4764     unsigned long len;
4765
4766     EXTEND(SP, 10);
4767     if (which == OP_GHBYNAME) {
4768 #ifdef HAS_GETHOSTBYNAME
4769         const char* const name = POPpbytex;
4770         hent = PerlSock_gethostbyname(name);
4771 #else
4772         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4773 #endif
4774     }
4775     else if (which == OP_GHBYADDR) {
4776 #ifdef HAS_GETHOSTBYADDR
4777         const int addrtype = POPi;
4778         SV * const addrsv = POPs;
4779         STRLEN addrlen;
4780         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4781
4782         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4783 #else
4784         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4785 #endif
4786     }
4787     else
4788 #ifdef HAS_GETHOSTENT
4789         hent = PerlSock_gethostent();
4790 #else
4791         DIE(aTHX_ PL_no_sock_func, "gethostent");
4792 #endif
4793
4794 #ifdef HOST_NOT_FOUND
4795         if (!hent) {
4796 #ifdef USE_REENTRANT_API
4797 #   ifdef USE_GETHOSTENT_ERRNO
4798             h_errno = PL_reentrant_buffer->_gethostent_errno;
4799 #   endif
4800 #endif
4801             STATUS_UNIX_SET(h_errno);
4802         }
4803 #endif
4804
4805     if (GIMME != G_ARRAY) {
4806         PUSHs(sv = sv_newmortal());
4807         if (hent) {
4808             if (which == OP_GHBYNAME) {
4809                 if (hent->h_addr)
4810                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4811             }
4812             else
4813                 sv_setpv(sv, (char*)hent->h_name);
4814         }
4815         RETURN;
4816     }
4817
4818     if (hent) {
4819         mPUSHs(newSVpv((char*)hent->h_name, 0));
4820         PUSHs(space_join_names_mortal(hent->h_aliases));
4821         mPUSHi(hent->h_addrtype);
4822         len = hent->h_length;
4823         mPUSHi(len);
4824 #ifdef h_addr
4825         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4826             mXPUSHp(*elem, len);
4827         }
4828 #else
4829         if (hent->h_addr)
4830             mPUSHp(hent->h_addr, len);
4831         else
4832             PUSHs(sv_mortalcopy(&PL_sv_no));
4833 #endif /* h_addr */
4834     }
4835     RETURN;
4836 #else
4837     DIE(aTHX_ PL_no_sock_func, "gethostent");
4838 #endif
4839 }
4840
4841 PP(pp_gnetent)
4842 {
4843 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4844     dVAR; dSP;
4845     I32 which = PL_op->op_type;
4846     register SV *sv;
4847 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4848     struct netent *getnetbyaddr(Netdb_net_t, int);
4849     struct netent *getnetbyname(Netdb_name_t);
4850     struct netent *getnetent(void);
4851 #endif
4852     struct netent *nent;
4853
4854     if (which == OP_GNBYNAME){
4855 #ifdef HAS_GETNETBYNAME
4856         const char * const name = POPpbytex;
4857         nent = PerlSock_getnetbyname(name);
4858 #else
4859         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4860 #endif
4861     }
4862     else if (which == OP_GNBYADDR) {
4863 #ifdef HAS_GETNETBYADDR
4864         const int addrtype = POPi;
4865         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4866         nent = PerlSock_getnetbyaddr(addr, addrtype);
4867 #else
4868         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4869 #endif
4870     }
4871     else
4872 #ifdef HAS_GETNETENT
4873         nent = PerlSock_getnetent();
4874 #else
4875         DIE(aTHX_ PL_no_sock_func, "getnetent");
4876 #endif
4877
4878 #ifdef HOST_NOT_FOUND
4879         if (!nent) {
4880 #ifdef USE_REENTRANT_API
4881 #   ifdef USE_GETNETENT_ERRNO
4882              h_errno = PL_reentrant_buffer->_getnetent_errno;
4883 #   endif
4884 #endif
4885             STATUS_UNIX_SET(h_errno);
4886         }
4887 #endif
4888
4889     EXTEND(SP, 4);
4890     if (GIMME != G_ARRAY) {
4891         PUSHs(sv = sv_newmortal());
4892         if (nent) {
4893             if (which == OP_GNBYNAME)
4894                 sv_setiv(sv, (IV)nent->n_net);
4895             else
4896                 sv_setpv(sv, nent->n_name);
4897         }
4898         RETURN;
4899     }
4900
4901     if (nent) {
4902         mPUSHs(newSVpv(nent->n_name, 0));
4903         PUSHs(space_join_names_mortal(nent->n_aliases));
4904         mPUSHi(nent->n_addrtype);
4905         mPUSHi(nent->n_net);
4906     }
4907
4908     RETURN;
4909 #else
4910     DIE(aTHX_ PL_no_sock_func, "getnetent");
4911 #endif
4912 }
4913
4914 PP(pp_gprotoent)
4915 {
4916 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4917     dVAR; dSP;
4918     I32 which = PL_op->op_type;
4919     register SV *sv;
4920 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4921     struct protoent *getprotobyname(Netdb_name_t);
4922     struct protoent *getprotobynumber(int);
4923     struct protoent *getprotoent(void);
4924 #endif
4925     struct protoent *pent;
4926
4927     if (which == OP_GPBYNAME) {
4928 #ifdef HAS_GETPROTOBYNAME
4929         const char* const name = POPpbytex;
4930         pent = PerlSock_getprotobyname(name);
4931 #else
4932         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4933 #endif
4934     }
4935     else if (which == OP_GPBYNUMBER) {
4936 #ifdef HAS_GETPROTOBYNUMBER
4937         const int number = POPi;
4938         pent = PerlSock_getprotobynumber(number);
4939 #else
4940         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4941 #endif
4942     }
4943     else
4944 #ifdef HAS_GETPROTOENT
4945         pent = PerlSock_getprotoent();
4946 #else
4947         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4948 #endif
4949
4950     EXTEND(SP, 3);
4951     if (GIMME != G_ARRAY) {
4952         PUSHs(sv = sv_newmortal());
4953         if (pent) {
4954             if (which == OP_GPBYNAME)
4955                 sv_setiv(sv, (IV)pent->p_proto);
4956             else
4957                 sv_setpv(sv, pent->p_name);
4958         }
4959         RETURN;
4960     }
4961
4962     if (pent) {
4963         mPUSHs(newSVpv(pent->p_name, 0));
4964         PUSHs(space_join_names_mortal(pent->p_aliases));
4965         mPUSHi(pent->p_proto);
4966     }
4967
4968     RETURN;
4969 #else
4970     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4971 #endif
4972 }
4973
4974 PP(pp_gservent)
4975 {
4976 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4977     dVAR; dSP;
4978     I32 which = PL_op->op_type;
4979     register SV *sv;
4980 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4981     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4982     struct servent *getservbyport(int, Netdb_name_t);
4983     struct servent *getservent(void);
4984 #endif
4985     struct servent *sent;
4986
4987     if (which == OP_GSBYNAME) {
4988 #ifdef HAS_GETSERVBYNAME
4989         const char * const proto = POPpbytex;
4990         const char * const name = POPpbytex;
4991         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4992 #else
4993         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4994 #endif
4995     }
4996     else if (which == OP_GSBYPORT) {
4997 #ifdef HAS_GETSERVBYPORT
4998         const char * const proto = POPpbytex;
4999         unsigned short port = (unsigned short)POPu;
5000 #ifdef HAS_HTONS
5001         port = PerlSock_htons(port);
5002 #endif
5003         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5004 #else
5005         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5006 #endif
5007     }
5008     else
5009 #ifdef HAS_GETSERVENT
5010         sent = PerlSock_getservent();
5011 #else
5012         DIE(aTHX_ PL_no_sock_func, "getservent");
5013 #endif
5014
5015     EXTEND(SP, 4);
5016     if (GIMME != G_ARRAY) {
5017         PUSHs(sv = sv_newmortal());
5018         if (sent) {
5019             if (which == OP_GSBYNAME) {
5020 #ifdef HAS_NTOHS
5021                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5022 #else
5023                 sv_setiv(sv, (IV)(sent->s_port));
5024 #endif
5025             }
5026             else
5027                 sv_setpv(sv, sent->s_name);
5028         }
5029         RETURN;
5030     }
5031
5032     if (sent) {
5033         mPUSHs(newSVpv(sent->s_name, 0));
5034         PUSHs(space_join_names_mortal(sent->s_aliases));
5035 #ifdef HAS_NTOHS
5036         mPUSHi(PerlSock_ntohs(sent->s_port));
5037 #else
5038         mPUSHi(sent->s_port);
5039 #endif
5040         mPUSHs(newSVpv(sent->s_proto, 0));
5041     }
5042
5043     RETURN;
5044 #else
5045     DIE(aTHX_ PL_no_sock_func, "getservent");
5046 #endif
5047 }
5048
5049 PP(pp_shostent)
5050 {
5051 #ifdef HAS_SETHOSTENT
5052     dVAR; dSP;
5053     PerlSock_sethostent(TOPi);
5054     RETSETYES;
5055 #else
5056     DIE(aTHX_ PL_no_sock_func, "sethostent");
5057 #endif
5058 }
5059
5060 PP(pp_snetent)
5061 {
5062 #ifdef HAS_SETNETENT
5063     dVAR; dSP;
5064     (void)PerlSock_setnetent(TOPi);
5065     RETSETYES;
5066 #else
5067     DIE(aTHX_ PL_no_sock_func, "setnetent");
5068 #endif
5069 }
5070
5071 PP(pp_sprotoent)
5072 {
5073 #ifdef HAS_SETPROTOENT
5074     dVAR; dSP;
5075     (void)PerlSock_setprotoent(TOPi);
5076     RETSETYES;
5077 #else
5078     DIE(aTHX_ PL_no_sock_func, "setprotoent");
5079 #endif
5080 }
5081
5082 PP(pp_sservent)
5083 {
5084 #ifdef HAS_SETSERVENT
5085     dVAR; dSP;
5086     (void)PerlSock_setservent(TOPi);
5087     RETSETYES;
5088 #else
5089     DIE(aTHX_ PL_no_sock_func, "setservent");
5090 #endif
5091 }
5092
5093 PP(pp_ehostent)
5094 {
5095 #ifdef HAS_ENDHOSTENT
5096     dVAR; dSP;
5097     PerlSock_endhostent();
5098     EXTEND(SP,1);
5099   &nb