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