This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Simplify return handling for tied handle OPEN/PRINTF/READ/WRITE.
[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, io, PL_op->op_type);
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, io, PL_op->op_type);
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, io, PL_op->op_type);
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 (ckWARN2(WARN_CLOSED,WARN_IO)) {
1453             if (IoIFP(io))
1454                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1455             else if (ckWARN(WARN_CLOSED))
1456                 report_evil_fh(gv, io, PL_op->op_type);
1457         }
1458         PUSHs(&PL_sv_no);
1459     }
1460     else {
1461         if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1462             Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1463         }
1464         if (!do_print(PL_formtarget, fp))
1465             PUSHs(&PL_sv_no);
1466         else {
1467             FmLINES(PL_formtarget) = 0;
1468             SvCUR_set(PL_formtarget, 0);
1469             *SvEND(PL_formtarget) = '\0';
1470             if (IoFLAGS(io) & IOf_FLUSH)
1471                 (void)PerlIO_flush(fp);
1472             PUSHs(&PL_sv_yes);
1473         }
1474     }
1475     /* bad_ofp: */
1476     PL_formtarget = PL_bodytarget;
1477     PUTBACK;
1478     PERL_UNUSED_VAR(newsp);
1479     PERL_UNUSED_VAR(gimme);
1480     return retop;
1481 }
1482
1483 PP(pp_prtf)
1484 {
1485     dVAR; dSP; dMARK; dORIGMARK;
1486     IO *io;
1487     PerlIO *fp;
1488     SV *sv;
1489
1490     GV * const gv
1491         = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1492
1493     if (gv && (io = GvIO(gv))) {
1494         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1495         if (mg) {
1496             if (MARK == ORIGMARK) {
1497                 MEXTEND(SP, 1);
1498                 ++MARK;
1499                 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1500                 ++SP;
1501             }
1502             PUSHMARK(MARK - 1);
1503             *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1504             PUTBACK;
1505             ENTER;
1506             call_method("PRINTF", G_SCALAR);
1507             LEAVE;
1508             return NORMAL;
1509         }
1510     }
1511
1512     sv = newSV(0);
1513     if (!(io = GvIO(gv))) {
1514         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1515             report_evil_fh(gv, io, PL_op->op_type);
1516         SETERRNO(EBADF,RMS_IFI);
1517         goto just_say_no;
1518     }
1519     else if (!(fp = IoOFP(io))) {
1520         if (ckWARN2(WARN_CLOSED,WARN_IO))  {
1521             if (IoIFP(io))
1522                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1523             else if (ckWARN(WARN_CLOSED))
1524                 report_evil_fh(gv, io, PL_op->op_type);
1525         }
1526         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1527         goto just_say_no;
1528     }
1529     else {
1530         if (SvTAINTED(MARK[1]))
1531             TAINT_PROPER("printf");
1532         do_sprintf(sv, SP - MARK, MARK + 1);
1533         if (!do_print(sv, fp))
1534             goto just_say_no;
1535
1536         if (IoFLAGS(io) & IOf_FLUSH)
1537             if (PerlIO_flush(fp) == EOF)
1538                 goto just_say_no;
1539     }
1540     SvREFCNT_dec(sv);
1541     SP = ORIGMARK;
1542     PUSHs(&PL_sv_yes);
1543     RETURN;
1544
1545   just_say_no:
1546     SvREFCNT_dec(sv);
1547     SP = ORIGMARK;
1548     PUSHs(&PL_sv_undef);
1549     RETURN;
1550 }
1551
1552 PP(pp_sysopen)
1553 {
1554     dVAR;
1555     dSP;
1556     const int perm = (MAXARG > 3) ? POPi : 0666;
1557     const int mode = POPi;
1558     SV * const sv = POPs;
1559     GV * const gv = MUTABLE_GV(POPs);
1560     STRLEN len;
1561
1562     /* Need TIEHANDLE method ? */
1563     const char * const tmps = SvPV_const(sv, len);
1564     /* FIXME? do_open should do const  */
1565     if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1566         IoLINES(GvIOp(gv)) = 0;
1567         PUSHs(&PL_sv_yes);
1568     }
1569     else {
1570         PUSHs(&PL_sv_undef);
1571     }
1572     RETURN;
1573 }
1574
1575 PP(pp_sysread)
1576 {
1577     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1578     int offset;
1579     IO *io;
1580     char *buffer;
1581     SSize_t length;
1582     SSize_t count;
1583     Sock_size_t bufsize;
1584     SV *bufsv;
1585     STRLEN blen;
1586     int fp_utf8;
1587     int buffer_utf8;
1588     SV *read_target;
1589     Size_t got = 0;
1590     Size_t wanted;
1591     bool charstart = FALSE;
1592     STRLEN charskip = 0;
1593     STRLEN skip = 0;
1594
1595     GV * const gv = MUTABLE_GV(*++MARK);
1596     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1597         && gv && (io = GvIO(gv)) )
1598     {
1599         const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1600         if (mg) {
1601             PUSHMARK(MARK-1);
1602             *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1603             ENTER;
1604             call_method("READ", G_SCALAR);
1605             LEAVE;
1606             return NORMAL;
1607         }
1608     }
1609
1610     if (!gv)
1611         goto say_undef;
1612     bufsv = *++MARK;
1613     if (! SvOK(bufsv))
1614         sv_setpvs(bufsv, "");
1615     length = SvIVx(*++MARK);
1616     SETERRNO(0,0);
1617     if (MARK < SP)
1618         offset = SvIVx(*++MARK);
1619     else
1620         offset = 0;
1621     io = GvIO(gv);
1622     if (!io || !IoIFP(io)) {
1623         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1624             report_evil_fh(gv, io, PL_op->op_type);
1625         SETERRNO(EBADF,RMS_IFI);
1626         goto say_undef;
1627     }
1628     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
1629         buffer = SvPVutf8_force(bufsv, blen);
1630         /* UTF-8 may not have been set if they are all low bytes */
1631         SvUTF8_on(bufsv);
1632         buffer_utf8 = 0;
1633     }
1634     else {
1635         buffer = SvPV_force(bufsv, blen);
1636         buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
1637     }
1638     if (length < 0)
1639         DIE(aTHX_ "Negative length");
1640     wanted = length;
1641
1642     charstart = TRUE;
1643     charskip  = 0;
1644     skip = 0;
1645
1646 #ifdef HAS_SOCKET
1647     if (PL_op->op_type == OP_RECV) {
1648         char namebuf[MAXPATHLEN];
1649 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
1650         bufsize = sizeof (struct sockaddr_in);
1651 #else
1652         bufsize = sizeof namebuf;
1653 #endif
1654 #ifdef OS2      /* At least Warp3+IAK: only the first byte of bufsize set */
1655         if (bufsize >= 256)
1656             bufsize = 255;
1657 #endif
1658         buffer = SvGROW(bufsv, (STRLEN)(length+1));
1659         /* 'offset' means 'flags' here */
1660         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1661                                   (struct sockaddr *)namebuf, &bufsize);
1662         if (count < 0)
1663             RETPUSHUNDEF;
1664         /* MSG_TRUNC can give oversized count; quietly lose it */
1665         if (count > length)
1666             count = length;
1667 #ifdef EPOC
1668         /* Bogus return without padding */
1669         bufsize = sizeof (struct sockaddr_in);
1670 #endif
1671         SvCUR_set(bufsv, count);
1672         *SvEND(bufsv) = '\0';
1673         (void)SvPOK_only(bufsv);
1674         if (fp_utf8)
1675             SvUTF8_on(bufsv);
1676         SvSETMAGIC(bufsv);
1677         /* This should not be marked tainted if the fp is marked clean */
1678         if (!(IoFLAGS(io) & IOf_UNTAINT))
1679             SvTAINTED_on(bufsv);
1680         SP = ORIGMARK;
1681         sv_setpvn(TARG, namebuf, bufsize);
1682         PUSHs(TARG);
1683         RETURN;
1684     }
1685 #else
1686     if (PL_op->op_type == OP_RECV)
1687         DIE(aTHX_ PL_no_sock_func, "recv");
1688 #endif
1689     if (DO_UTF8(bufsv)) {
1690         /* offset adjust in characters not bytes */
1691         blen = sv_len_utf8(bufsv);
1692     }
1693     if (offset < 0) {
1694         if (-offset > (int)blen)
1695             DIE(aTHX_ "Offset outside string");
1696         offset += blen;
1697     }
1698     if (DO_UTF8(bufsv)) {
1699         /* convert offset-as-chars to offset-as-bytes */
1700         if (offset >= (int)blen)
1701             offset += SvCUR(bufsv) - blen;
1702         else
1703             offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1704     }
1705  more_bytes:
1706     bufsize = SvCUR(bufsv);
1707     /* Allocating length + offset + 1 isn't perfect in the case of reading
1708        bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1709        unduly.
1710        (should be 2 * length + offset + 1, or possibly something longer if
1711        PL_encoding is true) */
1712     buffer  = SvGROW(bufsv, (STRLEN)(length+offset+1));
1713     if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
1714         Zero(buffer+bufsize, offset-bufsize, char);
1715     }
1716     buffer = buffer + offset;
1717     if (!buffer_utf8) {
1718         read_target = bufsv;
1719     } else {
1720         /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1721            concatenate it to the current buffer.  */
1722
1723         /* Truncate the existing buffer to the start of where we will be
1724            reading to:  */
1725         SvCUR_set(bufsv, offset);
1726
1727         read_target = sv_newmortal();
1728         SvUPGRADE(read_target, SVt_PV);
1729         buffer = SvGROW(read_target, (STRLEN)(length + 1));
1730     }
1731
1732     if (PL_op->op_type == OP_SYSREAD) {
1733 #ifdef PERL_SOCK_SYSREAD_IS_RECV
1734         if (IoTYPE(io) == IoTYPE_SOCKET) {
1735             count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1736                                    buffer, length, 0);
1737         }
1738         else
1739 #endif
1740         {
1741             count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1742                                   buffer, length);
1743         }
1744     }
1745     else
1746 #ifdef HAS_SOCKET__bad_code_maybe
1747     if (IoTYPE(io) == IoTYPE_SOCKET) {
1748         char namebuf[MAXPATHLEN];
1749 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1750         bufsize = sizeof (struct sockaddr_in);
1751 #else
1752         bufsize = sizeof namebuf;
1753 #endif
1754         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1755                           (struct sockaddr *)namebuf, &bufsize);
1756     }
1757     else
1758 #endif
1759     {
1760         count = PerlIO_read(IoIFP(io), buffer, length);
1761         /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1762         if (count == 0 && PerlIO_error(IoIFP(io)))
1763             count = -1;
1764     }
1765     if (count < 0) {
1766         if ((IoTYPE(io) == IoTYPE_WRONLY) && ckWARN(WARN_IO))
1767                 report_evil_fh(gv, io, OP_phoney_OUTPUT_ONLY);
1768         goto say_undef;
1769     }
1770     SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1771     *SvEND(read_target) = '\0';
1772     (void)SvPOK_only(read_target);
1773     if (fp_utf8 && !IN_BYTES) {
1774         /* Look at utf8 we got back and count the characters */
1775         const char *bend = buffer + count;
1776         while (buffer < bend) {
1777             if (charstart) {
1778                 skip = UTF8SKIP(buffer);
1779                 charskip = 0;
1780             }
1781             if (buffer - charskip + skip > bend) {
1782                 /* partial character - try for rest of it */
1783                 length = skip - (bend-buffer);
1784                 offset = bend - SvPVX_const(bufsv);
1785                 charstart = FALSE;
1786                 charskip += count;
1787                 goto more_bytes;
1788             }
1789             else {
1790                 got++;
1791                 buffer += skip;
1792                 charstart = TRUE;
1793                 charskip  = 0;
1794             }
1795         }
1796         /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1797            provided amount read (count) was what was requested (length)
1798          */
1799         if (got < wanted && count == length) {
1800             length = wanted - got;
1801             offset = bend - SvPVX_const(bufsv);
1802             goto more_bytes;
1803         }
1804         /* return value is character count */
1805         count = got;
1806         SvUTF8_on(bufsv);
1807     }
1808     else if (buffer_utf8) {
1809         /* Let svcatsv upgrade the bytes we read in to utf8.
1810            The buffer is a mortal so will be freed soon.  */
1811         sv_catsv_nomg(bufsv, read_target);
1812     }
1813     SvSETMAGIC(bufsv);
1814     /* This should not be marked tainted if the fp is marked clean */
1815     if (!(IoFLAGS(io) & IOf_UNTAINT))
1816         SvTAINTED_on(bufsv);
1817     SP = ORIGMARK;
1818     PUSHi(count);
1819     RETURN;
1820
1821   say_undef:
1822     SP = ORIGMARK;
1823     RETPUSHUNDEF;
1824 }
1825
1826 PP(pp_send)
1827 {
1828     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1829     IO *io;
1830     SV *bufsv;
1831     const char *buffer;
1832     SSize_t retval;
1833     STRLEN blen;
1834     STRLEN orig_blen_bytes;
1835     const int op_type = PL_op->op_type;
1836     bool doing_utf8;
1837     U8 *tmpbuf = NULL;
1838     
1839     GV *const gv = MUTABLE_GV(*++MARK);
1840     if (PL_op->op_type == OP_SYSWRITE
1841         && gv && (io = GvIO(gv))) {
1842         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1843         if (mg) {
1844             if (MARK == SP - 1) {
1845                 mXPUSHi(sv_len(*SP));
1846                 PUTBACK;
1847             }
1848
1849             PUSHMARK(ORIGMARK);
1850             *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1851             ENTER;
1852             call_method("WRITE", G_SCALAR);
1853             LEAVE;
1854             return NORMAL;
1855         }
1856     }
1857     if (!gv)
1858         goto say_undef;
1859
1860     bufsv = *++MARK;
1861
1862     SETERRNO(0,0);
1863     io = GvIO(gv);
1864     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1865         retval = -1;
1866         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1867             if (io && IoIFP(io))
1868                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1869             else
1870                 report_evil_fh(gv, io, PL_op->op_type);
1871         }
1872         SETERRNO(EBADF,RMS_IFI);
1873         goto say_undef;
1874     }
1875
1876     /* Do this first to trigger any overloading.  */
1877     buffer = SvPV_const(bufsv, blen);
1878     orig_blen_bytes = blen;
1879     doing_utf8 = DO_UTF8(bufsv);
1880
1881     if (PerlIO_isutf8(IoIFP(io))) {
1882         if (!SvUTF8(bufsv)) {
1883             /* We don't modify the original scalar.  */
1884             tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1885             buffer = (char *) tmpbuf;
1886             doing_utf8 = TRUE;
1887         }
1888     }
1889     else if (doing_utf8) {
1890         STRLEN tmplen = blen;
1891         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1892         if (!doing_utf8) {
1893             tmpbuf = result;
1894             buffer = (char *) tmpbuf;
1895             blen = tmplen;
1896         }
1897         else {
1898             assert((char *)result == buffer);
1899             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1900         }
1901     }
1902
1903     if (op_type == OP_SYSWRITE) {
1904         Size_t length = 0; /* This length is in characters.  */
1905         STRLEN blen_chars;
1906         IV offset;
1907
1908         if (doing_utf8) {
1909             if (tmpbuf) {
1910                 /* The SV is bytes, and we've had to upgrade it.  */
1911                 blen_chars = orig_blen_bytes;
1912             } else {
1913                 /* The SV really is UTF-8.  */
1914                 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1915                     /* Don't call sv_len_utf8 again because it will call magic
1916                        or overloading a second time, and we might get back a
1917                        different result.  */
1918                     blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1919                 } else {
1920                     /* It's safe, and it may well be cached.  */
1921                     blen_chars = sv_len_utf8(bufsv);
1922                 }
1923             }
1924         } else {
1925             blen_chars = blen;
1926         }
1927
1928         if (MARK >= SP) {
1929             length = blen_chars;
1930         } else {
1931 #if Size_t_size > IVSIZE
1932             length = (Size_t)SvNVx(*++MARK);
1933 #else
1934             length = (Size_t)SvIVx(*++MARK);
1935 #endif
1936             if ((SSize_t)length < 0) {
1937                 Safefree(tmpbuf);
1938                 DIE(aTHX_ "Negative length");
1939             }
1940         }
1941
1942         if (MARK < SP) {
1943             offset = SvIVx(*++MARK);
1944             if (offset < 0) {
1945                 if (-offset > (IV)blen_chars) {
1946                     Safefree(tmpbuf);
1947                     DIE(aTHX_ "Offset outside string");
1948                 }
1949                 offset += blen_chars;
1950             } else if (offset > (IV)blen_chars) {
1951                 Safefree(tmpbuf);
1952                 DIE(aTHX_ "Offset outside string");
1953             }
1954         } else
1955             offset = 0;
1956         if (length > blen_chars - offset)
1957             length = blen_chars - offset;
1958         if (doing_utf8) {
1959             /* Here we convert length from characters to bytes.  */
1960             if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1961                 /* Either we had to convert the SV, or the SV is magical, or
1962                    the SV has overloading, in which case we can't or mustn't
1963                    or mustn't call it again.  */
1964
1965                 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1966                 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1967             } else {
1968                 /* It's a real UTF-8 SV, and it's not going to change under
1969                    us.  Take advantage of any cache.  */
1970                 I32 start = offset;
1971                 I32 len_I32 = length;
1972
1973                 /* Convert the start and end character positions to bytes.
1974                    Remember that the second argument to sv_pos_u2b is relative
1975                    to the first.  */
1976                 sv_pos_u2b(bufsv, &start, &len_I32);
1977
1978                 buffer += start;
1979                 length = len_I32;
1980             }
1981         }
1982         else {
1983             buffer = buffer+offset;
1984         }
1985 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1986         if (IoTYPE(io) == IoTYPE_SOCKET) {
1987             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1988                                    buffer, length, 0);
1989         }
1990         else
1991 #endif
1992         {
1993             /* See the note at doio.c:do_print about filesize limits. --jhi */
1994             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1995                                    buffer, length);
1996         }
1997     }
1998 #ifdef HAS_SOCKET
1999     else {
2000         const int flags = SvIVx(*++MARK);
2001         if (SP > MARK) {
2002             STRLEN mlen;
2003             char * const sockbuf = SvPVx(*++MARK, mlen);
2004             retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2005                                      flags, (struct sockaddr *)sockbuf, mlen);
2006         }
2007         else {
2008             retval
2009                 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2010         }
2011     }
2012 #else
2013     else
2014         DIE(aTHX_ PL_no_sock_func, "send");
2015 #endif
2016
2017     if (retval < 0)
2018         goto say_undef;
2019     SP = ORIGMARK;
2020     if (doing_utf8)
2021         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2022
2023     Safefree(tmpbuf);
2024 #if Size_t_size > IVSIZE
2025     PUSHn(retval);
2026 #else
2027     PUSHi(retval);
2028 #endif
2029     RETURN;
2030
2031   say_undef:
2032     Safefree(tmpbuf);
2033     SP = ORIGMARK;
2034     RETPUSHUNDEF;
2035 }
2036
2037 PP(pp_eof)
2038 {
2039     dVAR; dSP;
2040     GV *gv;
2041     IO *io;
2042     MAGIC *mg;
2043     /*
2044      * in Perl 5.12 and later, the additional parameter is a bitmask:
2045      * 0 = eof
2046      * 1 = eof(FH)
2047      * 2 = eof()  <- ARGV magic
2048      *
2049      * I'll rely on the compiler's trace flow analysis to decide whether to
2050      * actually assign this out here, or punt it into the only block where it is
2051      * used. Doing it out here is DRY on the condition logic.
2052      */
2053     unsigned int which;
2054
2055     if (MAXARG) {
2056         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2057         which = 1;
2058     }
2059     else {
2060         EXTEND(SP, 1);
2061
2062         if (PL_op->op_flags & OPf_SPECIAL) {
2063             gv = PL_last_in_gv = GvEGVx(PL_argvgv);     /* eof() - ARGV magic */
2064             which = 2;
2065         }
2066         else {
2067             gv = PL_last_in_gv;                 /* eof */
2068             which = 0;
2069         }
2070     }
2071
2072     if (!gv)
2073         RETPUSHNO;
2074
2075     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2076         return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
2077     }
2078
2079     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {   /* eof() */
2080         if (io && !IoIFP(io)) {
2081             if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2082                 IoLINES(io) = 0;
2083                 IoFLAGS(io) &= ~IOf_START;
2084                 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2085                 if (GvSV(gv))
2086                     sv_setpvs(GvSV(gv), "-");
2087                 else
2088                     GvSV(gv) = newSVpvs("-");
2089                 SvSETMAGIC(GvSV(gv));
2090             }
2091             else if (!nextargv(gv))
2092                 RETPUSHYES;
2093         }
2094     }
2095
2096     PUSHs(boolSV(do_eof(gv)));
2097     RETURN;
2098 }
2099
2100 PP(pp_tell)
2101 {
2102     dVAR; dSP; dTARGET;
2103     GV *gv;
2104     IO *io;
2105
2106     if (MAXARG != 0)
2107         PL_last_in_gv = MUTABLE_GV(POPs);
2108     else
2109         EXTEND(SP, 1);
2110     gv = PL_last_in_gv;
2111
2112     if (gv && (io = GvIO(gv))) {
2113         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2114         if (mg) {
2115             return tied_handle_method("TELL", SP, io, mg);
2116         }
2117     }
2118     else if (!gv) {
2119         if (!errno)
2120             SETERRNO(EBADF,RMS_IFI);
2121         PUSHi(-1);
2122         RETURN;
2123     }
2124
2125 #if LSEEKSIZE > IVSIZE
2126     PUSHn( do_tell(gv) );
2127 #else
2128     PUSHi( do_tell(gv) );
2129 #endif
2130     RETURN;
2131 }
2132
2133 PP(pp_sysseek)
2134 {
2135     dVAR; dSP;
2136     const int whence = POPi;
2137 #if LSEEKSIZE > IVSIZE
2138     const Off_t offset = (Off_t)SvNVx(POPs);
2139 #else
2140     const Off_t offset = (Off_t)SvIVx(POPs);
2141 #endif
2142
2143     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2144     IO *io;
2145
2146     if (gv && (io = GvIO(gv))) {
2147         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2148         if (mg) {
2149 #if LSEEKSIZE > IVSIZE
2150             SV *const offset_sv = newSVnv((NV) offset);
2151 #else
2152             SV *const offset_sv = newSViv(offset);
2153 #endif
2154
2155             return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
2156                                        newSViv(whence));
2157         }
2158     }
2159
2160     if (PL_op->op_type == OP_SEEK)
2161         PUSHs(boolSV(do_seek(gv, offset, whence)));
2162     else {
2163         const Off_t sought = do_sysseek(gv, offset, whence);
2164         if (sought < 0)
2165             PUSHs(&PL_sv_undef);
2166         else {
2167             SV* const sv = sought ?
2168 #if LSEEKSIZE > IVSIZE
2169                 newSVnv((NV)sought)
2170 #else
2171                 newSViv(sought)
2172 #endif
2173                 : newSVpvn(zero_but_true, ZBTLEN);
2174             mPUSHs(sv);
2175         }
2176     }
2177     RETURN;
2178 }
2179
2180 PP(pp_truncate)
2181 {
2182     dVAR;
2183     dSP;
2184     /* There seems to be no consensus on the length type of truncate()
2185      * and ftruncate(), both off_t and size_t have supporters. In
2186      * general one would think that when using large files, off_t is
2187      * at least as wide as size_t, so using an off_t should be okay. */
2188     /* XXX Configure probe for the length type of *truncate() needed XXX */
2189     Off_t len;
2190
2191 #if Off_t_size > IVSIZE
2192     len = (Off_t)POPn;
2193 #else
2194     len = (Off_t)POPi;
2195 #endif
2196     /* Checking for length < 0 is problematic as the type might or
2197      * might not be signed: if it is not, clever compilers will moan. */
2198     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2199     SETERRNO(0,0);
2200     {
2201         int result = 1;
2202         GV *tmpgv;
2203         IO *io;
2204
2205         if (PL_op->op_flags & OPf_SPECIAL) {
2206             tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2207
2208         do_ftruncate_gv:
2209             if (!GvIO(tmpgv))
2210                 result = 0;
2211             else {
2212                 PerlIO *fp;
2213                 io = GvIOp(tmpgv);
2214             do_ftruncate_io:
2215                 TAINT_PROPER("truncate");
2216                 if (!(fp = IoIFP(io))) {
2217                     result = 0;
2218                 }
2219                 else {
2220                     PerlIO_flush(fp);
2221 #ifdef HAS_TRUNCATE
2222                     if (ftruncate(PerlIO_fileno(fp), len) < 0)
2223 #else
2224                     if (my_chsize(PerlIO_fileno(fp), len) < 0)
2225 #endif
2226                         result = 0;
2227                 }
2228             }
2229         }
2230         else {
2231             SV * const sv = POPs;
2232             const char *name;
2233
2234             if (isGV_with_GP(sv)) {
2235                 tmpgv = MUTABLE_GV(sv);         /* *main::FRED for example */
2236                 goto do_ftruncate_gv;
2237             }
2238             else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2239                 tmpgv = MUTABLE_GV(SvRV(sv));   /* \*main::FRED for example */
2240                 goto do_ftruncate_gv;
2241             }
2242             else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2243                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2244                 goto do_ftruncate_io;
2245             }
2246
2247             name = SvPV_nolen_const(sv);
2248             TAINT_PROPER("truncate");
2249 #ifdef HAS_TRUNCATE
2250             if (truncate(name, len) < 0)
2251                 result = 0;
2252 #else
2253             {
2254                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2255
2256                 if (tmpfd < 0)
2257                     result = 0;
2258                 else {
2259                     if (my_chsize(tmpfd, len) < 0)
2260                         result = 0;
2261                     PerlLIO_close(tmpfd);
2262                 }
2263             }
2264 #endif
2265         }
2266
2267         if (result)
2268             RETPUSHYES;
2269         if (!errno)
2270             SETERRNO(EBADF,RMS_IFI);
2271         RETPUSHUNDEF;
2272     }
2273 }
2274
2275 PP(pp_ioctl)
2276 {
2277     dVAR; dSP; dTARGET;
2278     SV * const argsv = POPs;
2279     const unsigned int func = POPu;
2280     const int optype = PL_op->op_type;
2281     GV * const gv = MUTABLE_GV(POPs);
2282     IO * const io = gv ? GvIOn(gv) : NULL;
2283     char *s;
2284     IV retval;
2285
2286     if (!io || !argsv || !IoIFP(io)) {
2287         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2288             report_evil_fh(gv, io, PL_op->op_type);
2289         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2290         RETPUSHUNDEF;
2291     }
2292
2293     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2294         STRLEN len;
2295         STRLEN need;
2296         s = SvPV_force(argsv, len);
2297         need = IOCPARM_LEN(func);
2298         if (len < need) {
2299             s = Sv_Grow(argsv, need + 1);
2300             SvCUR_set(argsv, need);
2301         }
2302
2303         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2304     }
2305     else {
2306         retval = SvIV(argsv);
2307         s = INT2PTR(char*,retval);              /* ouch */
2308     }
2309
2310     TAINT_PROPER(PL_op_desc[optype]);
2311
2312     if (optype == OP_IOCTL)
2313 #ifdef HAS_IOCTL
2314         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2315 #else
2316         DIE(aTHX_ "ioctl is not implemented");
2317 #endif
2318     else
2319 #ifndef HAS_FCNTL
2320       DIE(aTHX_ "fcntl is not implemented");
2321 #else
2322 #if defined(OS2) && defined(__EMX__)
2323         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2324 #else
2325         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2326 #endif
2327 #endif
2328
2329 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2330     if (SvPOK(argsv)) {
2331         if (s[SvCUR(argsv)] != 17)
2332             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2333                 OP_NAME(PL_op));
2334         s[SvCUR(argsv)] = 0;            /* put our null back */
2335         SvSETMAGIC(argsv);              /* Assume it has changed */
2336     }
2337
2338     if (retval == -1)
2339         RETPUSHUNDEF;
2340     if (retval != 0) {
2341         PUSHi(retval);
2342     }
2343     else {
2344         PUSHp(zero_but_true, ZBTLEN);
2345     }
2346 #endif
2347     RETURN;
2348 }
2349
2350 PP(pp_flock)
2351 {
2352 #ifdef FLOCK
2353     dVAR; dSP; dTARGET;
2354     I32 value;
2355     IO *io = NULL;
2356     PerlIO *fp;
2357     const int argtype = POPi;
2358     GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2359
2360     if (gv && (io = GvIO(gv)))
2361         fp = IoIFP(io);
2362     else {
2363         fp = NULL;
2364         io = NULL;
2365     }
2366     /* XXX Looks to me like io is always NULL at this point */
2367     if (fp) {
2368         (void)PerlIO_flush(fp);
2369         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2370     }
2371     else {
2372         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2373             report_evil_fh(gv, io, PL_op->op_type);
2374         value = 0;
2375         SETERRNO(EBADF,RMS_IFI);
2376     }
2377     PUSHi(value);
2378     RETURN;
2379 #else
2380     DIE(aTHX_ PL_no_func, "flock()");
2381 #endif
2382 }
2383
2384 /* Sockets. */
2385
2386 PP(pp_socket)
2387 {
2388 #ifdef HAS_SOCKET
2389     dVAR; dSP;
2390     const int protocol = POPi;
2391     const int type = POPi;
2392     const int domain = POPi;
2393     GV * const gv = MUTABLE_GV(POPs);
2394     register IO * const io = gv ? GvIOn(gv) : NULL;
2395     int fd;
2396
2397     if (!gv || !io) {
2398         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2399             report_evil_fh(gv, io, PL_op->op_type);
2400         if (io && IoIFP(io))
2401             do_close(gv, FALSE);
2402         SETERRNO(EBADF,LIB_INVARG);
2403         RETPUSHUNDEF;
2404     }
2405
2406     if (IoIFP(io))
2407         do_close(gv, FALSE);
2408
2409     TAINT_PROPER("socket");
2410     fd = PerlSock_socket(domain, type, protocol);
2411     if (fd < 0)
2412         RETPUSHUNDEF;
2413     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2414     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2415     IoTYPE(io) = IoTYPE_SOCKET;
2416     if (!IoIFP(io) || !IoOFP(io)) {
2417         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2418         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2419         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2420         RETPUSHUNDEF;
2421     }
2422 #if defined(HAS_FCNTL) && defined(F_SETFD)
2423     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2424 #endif
2425
2426 #ifdef EPOC
2427     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2428 #endif
2429
2430     RETPUSHYES;
2431 #else
2432     DIE(aTHX_ PL_no_sock_func, "socket");
2433 #endif
2434 }
2435
2436 PP(pp_sockpair)
2437 {
2438 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2439     dVAR; dSP;
2440     const int protocol = POPi;
2441     const int type = POPi;
2442     const int domain = POPi;
2443     GV * const gv2 = MUTABLE_GV(POPs);
2444     GV * const gv1 = MUTABLE_GV(POPs);
2445     register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2446     register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2447     int fd[2];
2448
2449     if (!gv1 || !gv2 || !io1 || !io2) {
2450         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2451             if (!gv1 || !io1)
2452                 report_evil_fh(gv1, io1, PL_op->op_type);
2453             if (!gv2 || !io2)
2454                 report_evil_fh(gv1, io2, PL_op->op_type);
2455         }
2456         if (io1 && IoIFP(io1))
2457             do_close(gv1, FALSE);
2458         if (io2 && IoIFP(io2))
2459             do_close(gv2, FALSE);
2460         RETPUSHUNDEF;
2461     }
2462
2463     if (IoIFP(io1))
2464         do_close(gv1, FALSE);
2465     if (IoIFP(io2))
2466         do_close(gv2, FALSE);
2467
2468     TAINT_PROPER("socketpair");
2469     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2470         RETPUSHUNDEF;
2471     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2472     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2473     IoTYPE(io1) = IoTYPE_SOCKET;
2474     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2475     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2476     IoTYPE(io2) = IoTYPE_SOCKET;
2477     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2478         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2479         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2480         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2481         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2482         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2483         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2484         RETPUSHUNDEF;
2485     }
2486 #if defined(HAS_FCNTL) && defined(F_SETFD)
2487     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2488     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2489 #endif
2490
2491     RETPUSHYES;
2492 #else
2493     DIE(aTHX_ PL_no_sock_func, "socketpair");
2494 #endif
2495 }
2496
2497 PP(pp_bind)
2498 {
2499 #ifdef HAS_SOCKET
2500     dVAR; dSP;
2501     SV * const addrsv = POPs;
2502     /* OK, so on what platform does bind modify addr?  */
2503     const char *addr;
2504     GV * const gv = MUTABLE_GV(POPs);
2505     register IO * const io = GvIOn(gv);
2506     STRLEN len;
2507
2508     if (!io || !IoIFP(io))
2509         goto nuts;
2510
2511     addr = SvPV_const(addrsv, len);
2512     TAINT_PROPER("bind");
2513     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2514         RETPUSHYES;
2515     else
2516         RETPUSHUNDEF;
2517
2518 nuts:
2519     if (ckWARN(WARN_CLOSED))
2520         report_evil_fh(gv, io, PL_op->op_type);
2521     SETERRNO(EBADF,SS_IVCHAN);
2522     RETPUSHUNDEF;
2523 #else
2524     DIE(aTHX_ PL_no_sock_func, "bind");
2525 #endif
2526 }
2527
2528 PP(pp_connect)
2529 {
2530 #ifdef HAS_SOCKET
2531     dVAR; dSP;
2532     SV * const addrsv = POPs;
2533     GV * const gv = MUTABLE_GV(POPs);
2534     register IO * const io = GvIOn(gv);
2535     const char *addr;
2536     STRLEN len;
2537
2538     if (!io || !IoIFP(io))
2539         goto nuts;
2540
2541     addr = SvPV_const(addrsv, len);
2542     TAINT_PROPER("connect");
2543     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2544         RETPUSHYES;
2545     else
2546         RETPUSHUNDEF;
2547
2548 nuts:
2549     if (ckWARN(WARN_CLOSED))
2550         report_evil_fh(gv, io, PL_op->op_type);
2551     SETERRNO(EBADF,SS_IVCHAN);
2552     RETPUSHUNDEF;
2553 #else
2554     DIE(aTHX_ PL_no_sock_func, "connect");
2555 #endif
2556 }
2557
2558 PP(pp_listen)
2559 {
2560 #ifdef HAS_SOCKET
2561     dVAR; dSP;
2562     const int backlog = POPi;
2563     GV * const gv = MUTABLE_GV(POPs);
2564     register IO * const io = gv ? GvIOn(gv) : NULL;
2565
2566     if (!gv || !io || !IoIFP(io))
2567         goto nuts;
2568
2569     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2570         RETPUSHYES;
2571     else
2572         RETPUSHUNDEF;
2573
2574 nuts:
2575     if (ckWARN(WARN_CLOSED))
2576         report_evil_fh(gv, io, PL_op->op_type);
2577     SETERRNO(EBADF,SS_IVCHAN);
2578     RETPUSHUNDEF;
2579 #else
2580     DIE(aTHX_ PL_no_sock_func, "listen");
2581 #endif
2582 }
2583
2584 PP(pp_accept)
2585 {
2586 #ifdef HAS_SOCKET
2587     dVAR; dSP; dTARGET;
2588     register IO *nstio;
2589     register IO *gstio;
2590     char namebuf[MAXPATHLEN];
2591 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2592     Sock_size_t len = sizeof (struct sockaddr_in);
2593 #else
2594     Sock_size_t len = sizeof namebuf;
2595 #endif
2596     GV * const ggv = MUTABLE_GV(POPs);
2597     GV * const ngv = MUTABLE_GV(POPs);
2598     int fd;
2599
2600     if (!ngv)
2601         goto badexit;
2602     if (!ggv)
2603         goto nuts;
2604
2605     gstio = GvIO(ggv);
2606     if (!gstio || !IoIFP(gstio))
2607         goto nuts;
2608
2609     nstio = GvIOn(ngv);
2610     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2611 #if defined(OEMVS)
2612     if (len == 0) {
2613         /* Some platforms indicate zero length when an AF_UNIX client is
2614          * not bound. Simulate a non-zero-length sockaddr structure in
2615          * this case. */
2616         namebuf[0] = 0;        /* sun_len */
2617         namebuf[1] = AF_UNIX;  /* sun_family */
2618         len = 2;
2619     }
2620 #endif
2621
2622     if (fd < 0)
2623         goto badexit;
2624     if (IoIFP(nstio))
2625         do_close(ngv, FALSE);
2626     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2627     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2628     IoTYPE(nstio) = IoTYPE_SOCKET;
2629     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2630         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2631         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2632         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2633         goto badexit;
2634     }
2635 #if defined(HAS_FCNTL) && defined(F_SETFD)
2636     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2637 #endif
2638
2639 #ifdef EPOC
2640     len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2641     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2642 #endif
2643 #ifdef __SCO_VERSION__
2644     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2645 #endif
2646
2647     PUSHp(namebuf, len);
2648     RETURN;
2649
2650 nuts:
2651     if (ckWARN(WARN_CLOSED))
2652         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2653     SETERRNO(EBADF,SS_IVCHAN);
2654
2655 badexit:
2656     RETPUSHUNDEF;
2657
2658 #else
2659     DIE(aTHX_ PL_no_sock_func, "accept");
2660 #endif
2661 }
2662
2663 PP(pp_shutdown)
2664 {
2665 #ifdef HAS_SOCKET
2666     dVAR; dSP; dTARGET;
2667     const int how = POPi;
2668     GV * const gv = MUTABLE_GV(POPs);
2669     register IO * const io = GvIOn(gv);
2670
2671     if (!io || !IoIFP(io))
2672         goto nuts;
2673
2674     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2675     RETURN;
2676
2677 nuts:
2678     if (ckWARN(WARN_CLOSED))
2679         report_evil_fh(gv, io, PL_op->op_type);
2680     SETERRNO(EBADF,SS_IVCHAN);
2681     RETPUSHUNDEF;
2682 #else
2683     DIE(aTHX_ PL_no_sock_func, "shutdown");
2684 #endif
2685 }
2686
2687 PP(pp_ssockopt)
2688 {
2689 #ifdef HAS_SOCKET
2690     dVAR; dSP;
2691     const int optype = PL_op->op_type;
2692     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2693     const unsigned int optname = (unsigned int) POPi;
2694     const unsigned int lvl = (unsigned int) POPi;
2695     GV * const gv = MUTABLE_GV(POPs);
2696     register IO * const io = GvIOn(gv);
2697     int fd;
2698     Sock_size_t len;
2699
2700     if (!io || !IoIFP(io))
2701         goto nuts;
2702
2703     fd = PerlIO_fileno(IoIFP(io));
2704     switch (optype) {
2705     case OP_GSOCKOPT:
2706         SvGROW(sv, 257);
2707         (void)SvPOK_only(sv);
2708         SvCUR_set(sv,256);
2709         *SvEND(sv) ='\0';
2710         len = SvCUR(sv);
2711         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2712             goto nuts2;
2713         SvCUR_set(sv, len);
2714         *SvEND(sv) ='\0';
2715         PUSHs(sv);
2716         break;
2717     case OP_SSOCKOPT: {
2718 #if defined(__SYMBIAN32__)
2719 # define SETSOCKOPT_OPTION_VALUE_T void *
2720 #else
2721 # define SETSOCKOPT_OPTION_VALUE_T const char *
2722 #endif
2723         /* XXX TODO: We need to have a proper type (a Configure probe,
2724          * etc.) for what the C headers think of the third argument of
2725          * setsockopt(), the option_value read-only buffer: is it
2726          * a "char *", or a "void *", const or not.  Some compilers
2727          * don't take kindly to e.g. assuming that "char *" implicitly
2728          * promotes to a "void *", or to explicitly promoting/demoting
2729          * consts to non/vice versa.  The "const void *" is the SUS
2730          * definition, but that does not fly everywhere for the above
2731          * reasons. */
2732             SETSOCKOPT_OPTION_VALUE_T buf;
2733             int aint;
2734             if (SvPOKp(sv)) {
2735                 STRLEN l;
2736                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2737                 len = l;
2738             }
2739             else {
2740                 aint = (int)SvIV(sv);
2741                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2742                 len = sizeof(int);
2743             }
2744             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2745                 goto nuts2;
2746             PUSHs(&PL_sv_yes);
2747         }
2748         break;
2749     }
2750     RETURN;
2751
2752 nuts:
2753     if (ckWARN(WARN_CLOSED))
2754         report_evil_fh(gv, io, optype);
2755     SETERRNO(EBADF,SS_IVCHAN);
2756 nuts2:
2757     RETPUSHUNDEF;
2758
2759 #else
2760     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2761 #endif
2762 }
2763
2764 PP(pp_getpeername)
2765 {
2766 #ifdef HAS_SOCKET
2767     dVAR; dSP;
2768     const int optype = PL_op->op_type;
2769     GV * const gv = MUTABLE_GV(POPs);
2770     register IO * const io = GvIOn(gv);
2771     Sock_size_t len;
2772     SV *sv;
2773     int fd;
2774
2775     if (!io || !IoIFP(io))
2776         goto nuts;
2777
2778     sv = sv_2mortal(newSV(257));
2779     (void)SvPOK_only(sv);
2780     len = 256;
2781     SvCUR_set(sv, len);
2782     *SvEND(sv) ='\0';
2783     fd = PerlIO_fileno(IoIFP(io));
2784     switch (optype) {
2785     case OP_GETSOCKNAME:
2786         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2787             goto nuts2;
2788         break;
2789     case OP_GETPEERNAME:
2790         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2791             goto nuts2;
2792 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2793         {
2794             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";
2795             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2796             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2797                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2798                         sizeof(u_short) + sizeof(struct in_addr))) {
2799                 goto nuts2;     
2800             }
2801         }
2802 #endif
2803         break;
2804     }
2805 #ifdef BOGUS_GETNAME_RETURN
2806     /* Interactive Unix, getpeername() and getsockname()
2807       does not return valid namelen */
2808     if (len == BOGUS_GETNAME_RETURN)
2809         len = sizeof(struct sockaddr);
2810 #endif
2811     SvCUR_set(sv, len);
2812     *SvEND(sv) ='\0';
2813     PUSHs(sv);
2814     RETURN;
2815
2816 nuts:
2817     if (ckWARN(WARN_CLOSED))
2818         report_evil_fh(gv, io, optype);
2819     SETERRNO(EBADF,SS_IVCHAN);
2820 nuts2:
2821     RETPUSHUNDEF;
2822
2823 #else
2824     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2825 #endif
2826 }
2827
2828 /* Stat calls. */
2829
2830 PP(pp_stat)
2831 {
2832     dVAR;
2833     dSP;
2834     GV *gv = NULL;
2835     IO *io;
2836     I32 gimme;
2837     I32 max = 13;
2838
2839     if (PL_op->op_flags & OPf_REF) {
2840         gv = cGVOP_gv;
2841         if (PL_op->op_type == OP_LSTAT) {
2842             if (gv != PL_defgv) {
2843             do_fstat_warning_check:
2844                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2845                                "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2846             } else if (PL_laststype != OP_LSTAT)
2847                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2848         }
2849
2850       do_fstat:
2851         if (gv != PL_defgv) {
2852             PL_laststype = OP_STAT;
2853             PL_statgv = gv;
2854             sv_setpvs(PL_statname, "");
2855             if(gv) {
2856                 io = GvIO(gv);
2857                 do_fstat_have_io:
2858                 if (io) {
2859                     if (IoIFP(io)) {
2860                         PL_laststatval = 
2861                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
2862                     } else if (IoDIRP(io)) {
2863                         PL_laststatval =
2864                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2865                     } else {
2866                         PL_laststatval = -1;
2867                     }
2868                 }
2869             }
2870         }
2871
2872         if (PL_laststatval < 0) {
2873             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2874                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2875             max = 0;
2876         }
2877     }
2878     else {
2879         SV* const sv = POPs;
2880         if (isGV_with_GP(sv)) {
2881             gv = MUTABLE_GV(sv);
2882             goto do_fstat;
2883         } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2884             gv = MUTABLE_GV(SvRV(sv));
2885             if (PL_op->op_type == OP_LSTAT)
2886                 goto do_fstat_warning_check;
2887             goto do_fstat;
2888         } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
2889             io = MUTABLE_IO(SvRV(sv));
2890             if (PL_op->op_type == OP_LSTAT)
2891                 goto do_fstat_warning_check;
2892             goto do_fstat_have_io; 
2893         }
2894         
2895         sv_setpv(PL_statname, SvPV_nolen_const(sv));
2896         PL_statgv = NULL;
2897         PL_laststype = PL_op->op_type;
2898         if (PL_op->op_type == OP_LSTAT)
2899             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2900         else
2901             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2902         if (PL_laststatval < 0) {
2903             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2904                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2905             max = 0;
2906         }
2907     }
2908
2909     gimme = GIMME_V;
2910     if (gimme != G_ARRAY) {
2911         if (gimme != G_VOID)
2912             XPUSHs(boolSV(max));
2913         RETURN;
2914     }
2915     if (max) {
2916         EXTEND(SP, max);
2917         EXTEND_MORTAL(max);
2918         mPUSHi(PL_statcache.st_dev);
2919         mPUSHi(PL_statcache.st_ino);
2920         mPUSHu(PL_statcache.st_mode);
2921         mPUSHu(PL_statcache.st_nlink);
2922 #if Uid_t_size > IVSIZE
2923         mPUSHn(PL_statcache.st_uid);
2924 #else
2925 #   if Uid_t_sign <= 0
2926         mPUSHi(PL_statcache.st_uid);
2927 #   else
2928         mPUSHu(PL_statcache.st_uid);
2929 #   endif
2930 #endif
2931 #if Gid_t_size > IVSIZE
2932         mPUSHn(PL_statcache.st_gid);
2933 #else
2934 #   if Gid_t_sign <= 0
2935         mPUSHi(PL_statcache.st_gid);
2936 #   else
2937         mPUSHu(PL_statcache.st_gid);
2938 #   endif
2939 #endif
2940 #ifdef USE_STAT_RDEV
2941         mPUSHi(PL_statcache.st_rdev);
2942 #else
2943         PUSHs(newSVpvs_flags("", SVs_TEMP));
2944 #endif
2945 #if Off_t_size > IVSIZE
2946         mPUSHn(PL_statcache.st_size);
2947 #else
2948         mPUSHi(PL_statcache.st_size);
2949 #endif
2950 #ifdef BIG_TIME
2951         mPUSHn(PL_statcache.st_atime);
2952         mPUSHn(PL_statcache.st_mtime);
2953         mPUSHn(PL_statcache.st_ctime);
2954 #else
2955         mPUSHi(PL_statcache.st_atime);
2956         mPUSHi(PL_statcache.st_mtime);
2957         mPUSHi(PL_statcache.st_ctime);
2958 #endif
2959 #ifdef USE_STAT_BLOCKS
2960         mPUSHu(PL_statcache.st_blksize);
2961         mPUSHu(PL_statcache.st_blocks);
2962 #else
2963         PUSHs(newSVpvs_flags("", SVs_TEMP));
2964         PUSHs(newSVpvs_flags("", SVs_TEMP));
2965 #endif
2966     }
2967     RETURN;
2968 }
2969
2970 #define tryAMAGICftest_MG(chr) STMT_START { \
2971         if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2972                 && S_try_amagic_ftest(aTHX_ chr)) \
2973             return NORMAL; \
2974     } STMT_END
2975
2976 STATIC bool
2977 S_try_amagic_ftest(pTHX_ char chr) {
2978     dVAR;
2979     dSP;
2980     SV* const arg = TOPs;
2981
2982     assert(chr != '?');
2983     SvGETMAGIC(arg);
2984
2985     if ((PL_op->op_flags & OPf_KIDS)
2986             && SvAMAGIC(TOPs))
2987     {
2988         const char tmpchr = chr;
2989         const OP *next;
2990         SV * const tmpsv = amagic_call(arg,
2991                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2992                                 ftest_amg, AMGf_unary);
2993
2994         if (!tmpsv)
2995             return FALSE;
2996
2997         SPAGAIN;
2998
2999         next = PL_op->op_next;
3000         if (next->op_type >= OP_FTRREAD &&
3001             next->op_type <= OP_FTBINARY &&
3002             next->op_private & OPpFT_STACKED
3003         ) {
3004             if (SvTRUE(tmpsv))
3005                 /* leave the object alone */
3006                 return TRUE;
3007         }
3008
3009         SETs(tmpsv);
3010         PUTBACK;
3011         return TRUE;
3012     }
3013     return FALSE;
3014 }
3015
3016
3017 /* This macro is used by the stacked filetest operators :
3018  * if the previous filetest failed, short-circuit and pass its value.
3019  * Else, discard it from the stack and continue. --rgs
3020  */
3021 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
3022         if (!SvTRUE(TOPs)) { RETURN; } \
3023         else { (void)POPs; PUTBACK; } \
3024     }
3025
3026 PP(pp_ftrread)
3027 {
3028     dVAR;
3029     I32 result;
3030     /* Not const, because things tweak this below. Not bool, because there's
3031        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
3032 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3033     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3034     /* Giving some sort of initial value silences compilers.  */
3035 #  ifdef R_OK
3036     int access_mode = R_OK;
3037 #  else
3038     int access_mode = 0;
3039 #  endif
3040 #else
3041     /* access_mode is never used, but leaving use_access in makes the
3042        conditional compiling below much clearer.  */
3043     I32 use_access = 0;
3044 #endif
3045     Mode_t stat_mode = S_IRUSR;
3046
3047     bool effective = FALSE;
3048     char opchar = '?';
3049     dSP;
3050
3051     switch (PL_op->op_type) {
3052     case OP_FTRREAD:    opchar = 'R'; break;
3053     case OP_FTRWRITE:   opchar = 'W'; break;
3054     case OP_FTREXEC:    opchar = 'X'; break;
3055     case OP_FTEREAD:    opchar = 'r'; break;
3056     case OP_FTEWRITE:   opchar = 'w'; break;
3057     case OP_FTEEXEC:    opchar = 'x'; break;
3058     }
3059     tryAMAGICftest_MG(opchar);
3060
3061     STACKED_FTEST_CHECK;
3062
3063     switch (PL_op->op_type) {
3064     case OP_FTRREAD:
3065 #if !(defined(HAS_ACCESS) && defined(R_OK))
3066         use_access = 0;
3067 #endif
3068         break;
3069
3070     case OP_FTRWRITE:
3071 #if defined(HAS_ACCESS) && defined(W_OK)
3072         access_mode = W_OK;
3073 #else
3074         use_access = 0;
3075 #endif
3076         stat_mode = S_IWUSR;
3077         break;
3078
3079     case OP_FTREXEC:
3080 #if defined(HAS_ACCESS) && defined(X_OK)
3081         access_mode = X_OK;
3082 #else
3083         use_access = 0;
3084 #endif
3085         stat_mode = S_IXUSR;
3086         break;
3087
3088     case OP_FTEWRITE:
3089 #ifdef PERL_EFF_ACCESS
3090         access_mode = W_OK;
3091 #endif
3092         stat_mode = S_IWUSR;
3093         /* fall through */
3094
3095     case OP_FTEREAD:
3096 #ifndef PERL_EFF_ACCESS
3097         use_access = 0;
3098 #endif
3099         effective = TRUE;
3100         break;
3101
3102     case OP_FTEEXEC:
3103 #ifdef PERL_EFF_ACCESS
3104         access_mode = X_OK;
3105 #else
3106         use_access = 0;
3107 #endif
3108         stat_mode = S_IXUSR;
3109         effective = TRUE;
3110         break;
3111     }
3112
3113     if (use_access) {
3114 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3115         const char *name = POPpx;
3116         if (effective) {
3117 #  ifdef PERL_EFF_ACCESS
3118             result = PERL_EFF_ACCESS(name, access_mode);
3119 #  else
3120             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3121                 OP_NAME(PL_op));
3122 #  endif
3123         }
3124         else {
3125 #  ifdef HAS_ACCESS
3126             result = access(name, access_mode);
3127 #  else
3128             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3129 #  endif
3130         }
3131         if (result == 0)
3132             RETPUSHYES;
3133         if (result < 0)
3134             RETPUSHUNDEF;
3135         RETPUSHNO;
3136 #endif
3137     }
3138
3139     result = my_stat_flags(0);
3140     SPAGAIN;
3141     if (result < 0)
3142         RETPUSHUNDEF;
3143     if (cando(stat_mode, effective, &PL_statcache))
3144         RETPUSHYES;
3145     RETPUSHNO;
3146 }
3147
3148 PP(pp_ftis)
3149 {
3150     dVAR;
3151     I32 result;
3152     const int op_type = PL_op->op_type;
3153     char opchar = '?';
3154     dSP;
3155
3156     switch (op_type) {
3157     case OP_FTIS:       opchar = 'e'; break;
3158     case OP_FTSIZE:     opchar = 's'; break;
3159     case OP_FTMTIME:    opchar = 'M'; break;
3160     case OP_FTCTIME:    opchar = 'C'; break;
3161     case OP_FTATIME:    opchar = 'A'; break;
3162     }
3163     tryAMAGICftest_MG(opchar);
3164
3165     STACKED_FTEST_CHECK;
3166
3167     result = my_stat_flags(0);
3168     SPAGAIN;
3169     if (result < 0)
3170         RETPUSHUNDEF;
3171     if (op_type == OP_FTIS)
3172         RETPUSHYES;
3173     {
3174         /* You can't dTARGET inside OP_FTIS, because you'll get
3175            "panic: pad_sv po" - the op is not flagged to have a target.  */
3176         dTARGET;
3177         switch (op_type) {
3178         case OP_FTSIZE:
3179 #if Off_t_size > IVSIZE
3180             PUSHn(PL_statcache.st_size);
3181 #else
3182             PUSHi(PL_statcache.st_size);
3183 #endif
3184             break;
3185         case OP_FTMTIME:
3186             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3187             break;
3188         case OP_FTATIME:
3189             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3190             break;
3191         case OP_FTCTIME:
3192             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3193             break;
3194         }
3195     }
3196     RETURN;
3197 }
3198
3199 PP(pp_ftrowned)
3200 {
3201     dVAR;
3202     I32 result;
3203     char opchar = '?';
3204     dSP;
3205
3206     switch (PL_op->op_type) {
3207     case OP_FTROWNED:   opchar = 'O'; break;
3208     case OP_FTEOWNED:   opchar = 'o'; break;
3209     case OP_FTZERO:     opchar = 'z'; break;
3210     case OP_FTSOCK:     opchar = 'S'; break;
3211     case OP_FTCHR:      opchar = 'c'; break;
3212     case OP_FTBLK:      opchar = 'b'; break;
3213     case OP_FTFILE:     opchar = 'f'; break;
3214     case OP_FTDIR:      opchar = 'd'; break;
3215     case OP_FTPIPE:     opchar = 'p'; break;
3216     case OP_FTSUID:     opchar = 'u'; break;
3217     case OP_FTSGID:     opchar = 'g'; break;
3218     case OP_FTSVTX:     opchar = 'k'; break;
3219     }
3220     tryAMAGICftest_MG(opchar);
3221
3222     STACKED_FTEST_CHECK;
3223
3224     /* I believe that all these three are likely to be defined on most every
3225        system these days.  */
3226 #ifndef S_ISUID
3227     if(PL_op->op_type == OP_FTSUID) {
3228         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3229             (void) POPs;
3230         RETPUSHNO;
3231     }
3232 #endif
3233 #ifndef S_ISGID
3234     if(PL_op->op_type == OP_FTSGID) {
3235         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3236             (void) POPs;
3237         RETPUSHNO;
3238     }
3239 #endif
3240 #ifndef S_ISVTX
3241     if(PL_op->op_type == OP_FTSVTX) {
3242         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3243             (void) POPs;
3244         RETPUSHNO;
3245     }
3246 #endif
3247
3248     result = my_stat_flags(0);
3249     SPAGAIN;
3250     if (result < 0)
3251         RETPUSHUNDEF;
3252     switch (PL_op->op_type) {
3253     case OP_FTROWNED:
3254         if (PL_statcache.st_uid == PL_uid)
3255             RETPUSHYES;
3256         break;
3257     case OP_FTEOWNED:
3258         if (PL_statcache.st_uid == PL_euid)
3259             RETPUSHYES;
3260         break;
3261     case OP_FTZERO:
3262         if (PL_statcache.st_size == 0)
3263             RETPUSHYES;
3264         break;
3265     case OP_FTSOCK:
3266         if (S_ISSOCK(PL_statcache.st_mode))
3267             RETPUSHYES;
3268         break;
3269     case OP_FTCHR:
3270         if (S_ISCHR(PL_statcache.st_mode))
3271             RETPUSHYES;
3272         break;
3273     case OP_FTBLK:
3274         if (S_ISBLK(PL_statcache.st_mode))
3275             RETPUSHYES;
3276         break;
3277     case OP_FTFILE:
3278         if (S_ISREG(PL_statcache.st_mode))
3279             RETPUSHYES;
3280         break;
3281     case OP_FTDIR:
3282         if (S_ISDIR(PL_statcache.st_mode))
3283             RETPUSHYES;
3284         break;
3285     case OP_FTPIPE:
3286         if (S_ISFIFO(PL_statcache.st_mode))
3287             RETPUSHYES;
3288         break;
3289 #ifdef S_ISUID
3290     case OP_FTSUID:
3291         if (PL_statcache.st_mode & S_ISUID)
3292             RETPUSHYES;
3293         break;
3294 #endif
3295 #ifdef S_ISGID
3296     case OP_FTSGID:
3297         if (PL_statcache.st_mode & S_ISGID)
3298             RETPUSHYES;
3299         break;
3300 #endif
3301 #ifdef S_ISVTX
3302     case OP_FTSVTX:
3303         if (PL_statcache.st_mode & S_ISVTX)
3304             RETPUSHYES;
3305         break;
3306 #endif
3307     }
3308     RETPUSHNO;
3309 }
3310
3311 PP(pp_ftlink)
3312 {
3313     dVAR;
3314     dSP;
3315     I32 result;
3316
3317     tryAMAGICftest_MG('l');
3318     result = my_lstat_flags(0);
3319     SPAGAIN;
3320
3321     if (result < 0)
3322         RETPUSHUNDEF;
3323     if (S_ISLNK(PL_statcache.st_mode))
3324         RETPUSHYES;
3325     RETPUSHNO;
3326 }
3327
3328 PP(pp_fttty)
3329 {
3330     dVAR;
3331     dSP;
3332     int fd;
3333     GV *gv;
3334     SV *tmpsv = NULL;
3335     char *name = NULL;
3336     STRLEN namelen;
3337
3338     tryAMAGICftest_MG('t');
3339
3340     STACKED_FTEST_CHECK;
3341
3342     if (PL_op->op_flags & OPf_REF)
3343         gv = cGVOP_gv;
3344     else if (isGV_with_GP(TOPs))
3345         gv = MUTABLE_GV(POPs);
3346     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3347         gv = MUTABLE_GV(SvRV(POPs));
3348     else {
3349         tmpsv = POPs;
3350         name = SvPV_nomg(tmpsv, namelen);
3351         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3352     }
3353
3354     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3355         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3356     else if (tmpsv && SvOK(tmpsv)) {
3357         if (isDIGIT(*name))
3358             fd = atoi(name);
3359         else 
3360             RETPUSHUNDEF;
3361     }
3362     else
3363         RETPUSHUNDEF;
3364     if (PerlLIO_isatty(fd))
3365         RETPUSHYES;
3366     RETPUSHNO;
3367 }
3368
3369 #if defined(atarist) /* this will work with atariST. Configure will
3370                         make guesses for other systems. */
3371 # define FILE_base(f) ((f)->_base)
3372 # define FILE_ptr(f) ((f)->_ptr)
3373 # define FILE_cnt(f) ((f)->_cnt)
3374 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3375 #endif
3376
3377 PP(pp_fttext)
3378 {
3379     dVAR;
3380     dSP;
3381     I32 i;
3382     I32 len;
3383     I32 odd = 0;
3384     STDCHAR tbuf[512];
3385     register STDCHAR *s;
3386     register IO *io;
3387     register SV *sv;
3388     GV *gv;
3389     PerlIO *fp;
3390
3391     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3392
3393     STACKED_FTEST_CHECK;
3394
3395     if (PL_op->op_flags & OPf_REF)
3396         gv = cGVOP_gv;
3397     else if (isGV_with_GP(TOPs))
3398         gv = MUTABLE_GV(POPs);
3399     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3400         gv = MUTABLE_GV(SvRV(POPs));
3401     else
3402         gv = NULL;
3403
3404     if (gv) {
3405         EXTEND(SP, 1);
3406         if (gv == PL_defgv) {
3407             if (PL_statgv)
3408                 io = GvIO(PL_statgv);
3409             else {
3410                 sv = PL_statname;
3411                 goto really_filename;
3412             }
3413         }
3414         else {
3415             PL_statgv = gv;
3416             PL_laststatval = -1;
3417             sv_setpvs(PL_statname, "");
3418             io = GvIO(PL_statgv);
3419         }
3420         if (io && IoIFP(io)) {
3421             if (! PerlIO_has_base(IoIFP(io)))
3422                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3423             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3424             if (PL_laststatval < 0)
3425                 RETPUSHUNDEF;
3426             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3427                 if (PL_op->op_type == OP_FTTEXT)
3428                     RETPUSHNO;
3429                 else
3430                     RETPUSHYES;
3431             }
3432             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3433                 i = PerlIO_getc(IoIFP(io));
3434                 if (i != EOF)
3435                     (void)PerlIO_ungetc(IoIFP(io),i);
3436             }
3437             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3438                 RETPUSHYES;
3439             len = PerlIO_get_bufsiz(IoIFP(io));
3440             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3441             /* sfio can have large buffers - limit to 512 */
3442             if (len > 512)
3443                 len = 512;
3444         }
3445         else {
3446             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3447                 gv = cGVOP_gv;
3448                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3449             }
3450             SETERRNO(EBADF,RMS_IFI);
3451             RETPUSHUNDEF;
3452         }
3453     }
3454     else {
3455         sv = POPs;
3456       really_filename:
3457         PL_statgv = NULL;
3458         PL_laststype = OP_STAT;
3459         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3460         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3461             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3462                                                '\n'))
3463                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3464             RETPUSHUNDEF;
3465         }
3466         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3467         if (PL_laststatval < 0) {
3468             (void)PerlIO_close(fp);
3469             RETPUSHUNDEF;
3470         }
3471         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3472         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3473         (void)PerlIO_close(fp);
3474         if (len <= 0) {
3475             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3476                 RETPUSHNO;              /* special case NFS directories */
3477             RETPUSHYES;         /* null file is anything */
3478         }
3479         s = tbuf;
3480     }
3481
3482     /* now scan s to look for textiness */
3483     /*   XXX ASCII dependent code */
3484
3485 #if defined(DOSISH) || defined(USEMYBINMODE)
3486     /* ignore trailing ^Z on short files */
3487     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3488         --len;
3489 #endif
3490
3491     for (i = 0; i < len; i++, s++) {
3492         if (!*s) {                      /* null never allowed in text */
3493             odd += len;
3494             break;
3495         }
3496 #ifdef EBCDIC
3497         else if (!(isPRINT(*s) || isSPACE(*s)))
3498             odd++;
3499 #else
3500         else if (*s & 128) {
3501 #ifdef USE_LOCALE
3502             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3503                 continue;
3504 #endif
3505             /* utf8 characters don't count as odd */
3506             if (UTF8_IS_START(*s)) {
3507                 int ulen = UTF8SKIP(s);
3508                 if (ulen < len - i) {
3509                     int j;
3510                     for (j = 1; j < ulen; j++) {
3511                         if (!UTF8_IS_CONTINUATION(s[j]))
3512                             goto not_utf8;
3513                     }
3514                     --ulen;     /* loop does extra increment */
3515                     s += ulen;
3516                     i += ulen;
3517                     continue;
3518                 }
3519             }
3520           not_utf8:
3521             odd++;
3522         }
3523         else if (*s < 32 &&
3524           *s != '\n' && *s != '\r' && *s != '\b' &&
3525           *s != '\t' && *s != '\f' && *s != 27)
3526             odd++;
3527 #endif
3528     }
3529
3530     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3531         RETPUSHNO;
3532     else
3533         RETPUSHYES;
3534 }
3535
3536 /* File calls. */
3537
3538 PP(pp_chdir)
3539 {
3540     dVAR; dSP; dTARGET;
3541     const char *tmps = NULL;
3542     GV *gv = NULL;
3543
3544     if( MAXARG == 1 ) {
3545         SV * const sv = POPs;
3546         if (PL_op->op_flags & OPf_SPECIAL) {
3547             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3548         }
3549         else if (isGV_with_GP(sv)) {
3550             gv = MUTABLE_GV(sv);
3551         }
3552         else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3553             gv = MUTABLE_GV(SvRV(sv));
3554         }
3555         else {
3556             tmps = SvPV_nolen_const(sv);
3557         }
3558     }
3559
3560     if( !gv && (!tmps || !*tmps) ) {
3561         HV * const table = GvHVn(PL_envgv);
3562         SV **svp;
3563
3564         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3565              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3566 #ifdef VMS
3567              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3568 #endif
3569            )
3570         {
3571             if( MAXARG == 1 )
3572                 deprecate("chdir('') or chdir(undef) as chdir()");
3573             tmps = SvPV_nolen_const(*svp);
3574         }
3575         else {
3576             PUSHi(0);
3577             TAINT_PROPER("chdir");
3578             RETURN;
3579         }
3580     }
3581
3582     TAINT_PROPER("chdir");
3583     if (gv) {
3584 #ifdef HAS_FCHDIR
3585         IO* const io = GvIO(gv);
3586         if (io) {
3587             if (IoDIRP(io)) {
3588                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3589             } else if (IoIFP(io)) {
3590                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3591             }
3592             else {
3593                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3594                     report_evil_fh(gv, io, PL_op->op_type);
3595                 SETERRNO(EBADF, RMS_IFI);
3596                 PUSHi(0);
3597             }
3598         }
3599         else {
3600             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3601                 report_evil_fh(gv, io, PL_op->op_type);
3602             SETERRNO(EBADF,RMS_IFI);
3603             PUSHi(0);
3604         }
3605 #else
3606         DIE(aTHX_ PL_no_func, "fchdir");
3607 #endif
3608     }
3609     else 
3610         PUSHi( PerlDir_chdir(tmps) >= 0 );
3611 #ifdef VMS
3612     /* Clear the DEFAULT element of ENV so we'll get the new value
3613      * in the future. */
3614     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3615 #endif
3616     RETURN;
3617 }
3618
3619 PP(pp_chown)
3620 {
3621     dVAR; dSP; dMARK; dTARGET;
3622     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3623
3624     SP = MARK;
3625     XPUSHi(value);
3626     RETURN;
3627 }
3628
3629 PP(pp_chroot)
3630 {
3631 #ifdef HAS_CHROOT
3632     dVAR; dSP; dTARGET;
3633     char * const tmps = POPpx;
3634     TAINT_PROPER("chroot");
3635     PUSHi( chroot(tmps) >= 0 );
3636     RETURN;
3637 #else
3638     DIE(aTHX_ PL_no_func, "chroot");
3639 #endif
3640 }
3641
3642 PP(pp_rename)
3643 {
3644     dVAR; dSP; dTARGET;
3645     int anum;
3646     const char * const tmps2 = POPpconstx;
3647     const char * const tmps = SvPV_nolen_const(TOPs);
3648     TAINT_PROPER("rename");
3649 #ifdef HAS_RENAME
3650     anum = PerlLIO_rename(tmps, tmps2);
3651 #else
3652     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3653         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3654             anum = 1;
3655         else {
3656             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3657                 (void)UNLINK(tmps2);
3658             if (!(anum = link(tmps, tmps2)))
3659                 anum = UNLINK(tmps);
3660         }
3661     }
3662 #endif
3663     SETi( anum >= 0 );
3664     RETURN;
3665 }
3666
3667 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3668 PP(pp_link)
3669 {
3670     dVAR; dSP; dTARGET;
3671     const int op_type = PL_op->op_type;
3672     int result;
3673
3674 #  ifndef HAS_LINK
3675     if (op_type == OP_LINK)
3676         DIE(aTHX_ PL_no_func, "link");
3677 #  endif
3678 #  ifndef HAS_SYMLINK
3679     if (op_type == OP_SYMLINK)
3680         DIE(aTHX_ PL_no_func, "symlink");
3681 #  endif
3682
3683     {
3684         const char * const tmps2 = POPpconstx;
3685         const char * const tmps = SvPV_nolen_const(TOPs);
3686         TAINT_PROPER(PL_op_desc[op_type]);
3687         result =
3688 #  if defined(HAS_LINK)
3689 #    if defined(HAS_SYMLINK)
3690             /* Both present - need to choose which.  */
3691             (op_type == OP_LINK) ?
3692             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3693 #    else
3694     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3695         PerlLIO_link(tmps, tmps2);
3696 #    endif
3697 #  else
3698 #    if defined(HAS_SYMLINK)
3699     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3700         symlink(tmps, tmps2);
3701 #    endif
3702 #  endif
3703     }
3704
3705     SETi( result >= 0 );
3706     RETURN;
3707 }
3708 #else
3709 PP(pp_link)
3710 {
3711     /* Have neither.  */
3712     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3713 }
3714 #endif
3715
3716 PP(pp_readlink)
3717 {
3718     dVAR;
3719     dSP;
3720 #ifdef HAS_SYMLINK
3721     dTARGET;
3722     const char *tmps;
3723     char buf[MAXPATHLEN];
3724     int len;
3725
3726 #ifndef INCOMPLETE_TAINTS
3727     TAINT;
3728 #endif
3729     tmps = POPpconstx;
3730     len = readlink(tmps, buf, sizeof(buf) - 1);
3731     if (len < 0)
3732         RETPUSHUNDEF;
3733     PUSHp(buf, len);
3734     RETURN;
3735 #else
3736     EXTEND(SP, 1);
3737     RETSETUNDEF;                /* just pretend it's a normal file */
3738 #endif
3739 }
3740
3741 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3742 STATIC int
3743 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3744 {
3745     char * const save_filename = filename;
3746     char *cmdline;
3747     char *s;
3748     PerlIO *myfp;
3749     int anum = 1;
3750     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3751
3752     PERL_ARGS_ASSERT_DOONELINER;
3753
3754     Newx(cmdline, size, char);
3755     my_strlcpy(cmdline, cmd, size);
3756     my_strlcat(cmdline, " ", size);
3757     for (s = cmdline + strlen(cmdline); *filename; ) {
3758         *s++ = '\\';
3759         *s++ = *filename++;
3760     }
3761     if (s - cmdline < size)
3762         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3763     myfp = PerlProc_popen(cmdline, "r");
3764     Safefree(cmdline);
3765
3766     if (myfp) {
3767         SV * const tmpsv = sv_newmortal();
3768         /* Need to save/restore 'PL_rs' ?? */
3769         s = sv_gets(tmpsv, myfp, 0);
3770         (void)PerlProc_pclose(myfp);
3771         if (s != NULL) {
3772             int e;
3773             for (e = 1;
3774 #ifdef HAS_SYS_ERRLIST
3775                  e <= sys_nerr
3776 #endif
3777                  ; e++)
3778             {
3779                 /* you don't see this */
3780                 const char * const errmsg =
3781 #ifdef HAS_SYS_ERRLIST
3782                     sys_errlist[e]
3783 #else
3784                     strerror(e)
3785 #endif
3786                     ;
3787                 if (!errmsg)
3788                     break;
3789                 if (instr(s, errmsg)) {
3790                     SETERRNO(e,0);
3791                     return 0;
3792                 }
3793             }
3794             SETERRNO(0,0);
3795 #ifndef EACCES
3796 #define EACCES EPERM
3797 #endif
3798             if (instr(s, "cannot make"))
3799                 SETERRNO(EEXIST,RMS_FEX);
3800             else if (instr(s, "existing file"))
3801                 SETERRNO(EEXIST,RMS_FEX);
3802             else if (instr(s, "ile exists"))
3803                 SETERRNO(EEXIST,RMS_FEX);
3804             else if (instr(s, "non-exist"))
3805                 SETERRNO(ENOENT,RMS_FNF);
3806             else if (instr(s, "does not exist"))
3807                 SETERRNO(ENOENT,RMS_FNF);
3808             else if (instr(s, "not empty"))
3809                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3810             else if (instr(s, "cannot access"))
3811                 SETERRNO(EACCES,RMS_PRV);
3812             else
3813                 SETERRNO(EPERM,RMS_PRV);
3814             return 0;
3815         }
3816         else {  /* some mkdirs return no failure indication */
3817             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3818             if (PL_op->op_type == OP_RMDIR)
3819                 anum = !anum;
3820             if (anum)
3821                 SETERRNO(0,0);
3822             else
3823                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3824         }
3825         return anum;
3826     }
3827     else
3828         return 0;
3829 }
3830 #endif
3831
3832 /* This macro removes trailing slashes from a directory name.
3833  * Different operating and file systems take differently to
3834  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3835  * any number of trailing slashes should be allowed.
3836  * Thusly we snip them away so that even non-conforming
3837  * systems are happy.
3838  * We should probably do this "filtering" for all
3839  * the functions that expect (potentially) directory names:
3840  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3841  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3842
3843 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3844     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3845         do { \
3846             (len)--; \
3847         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3848         (tmps) = savepvn((tmps), (len)); \
3849         (copy) = TRUE; \
3850     }
3851
3852 PP(pp_mkdir)
3853 {
3854     dVAR; dSP; dTARGET;
3855     STRLEN len;
3856     const char *tmps;
3857     bool copy = FALSE;
3858     const int mode = (MAXARG > 1) ? POPi : 0777;
3859
3860     TRIMSLASHES(tmps,len,copy);
3861
3862     TAINT_PROPER("mkdir");
3863 #ifdef HAS_MKDIR
3864     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3865 #else
3866     {
3867     int oldumask;
3868     SETi( dooneliner("mkdir", tmps) );
3869     oldumask = PerlLIO_umask(0);
3870     PerlLIO_umask(oldumask);
3871     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3872     }
3873 #endif
3874     if (copy)
3875         Safefree(tmps);
3876     RETURN;
3877 }
3878
3879 PP(pp_rmdir)
3880 {
3881     dVAR; dSP; dTARGET;
3882     STRLEN len;
3883     const char *tmps;
3884     bool copy = FALSE;
3885
3886     TRIMSLASHES(tmps,len,copy);
3887     TAINT_PROPER("rmdir");
3888 #ifdef HAS_RMDIR
3889     SETi( PerlDir_rmdir(tmps) >= 0 );
3890 #else
3891     SETi( dooneliner("rmdir", tmps) );
3892 #endif
3893     if (copy)
3894         Safefree(tmps);
3895     RETURN;
3896 }
3897
3898 /* Directory calls. */
3899
3900 PP(pp_open_dir)
3901 {
3902 #if defined(Direntry_t) && defined(HAS_READDIR)
3903     dVAR; dSP;
3904     const char * const dirname = POPpconstx;
3905     GV * const gv = MUTABLE_GV(POPs);
3906     register IO * const io = GvIOn(gv);
3907
3908     if (!io)
3909         goto nope;
3910
3911     if ((IoIFP(io) || IoOFP(io)))
3912         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3913                          "Opening filehandle %s also as a directory",
3914                          GvENAME(gv));
3915     if (IoDIRP(io))
3916         PerlDir_close(IoDIRP(io));
3917     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3918         goto nope;
3919
3920     RETPUSHYES;
3921 nope:
3922     if (!errno)
3923         SETERRNO(EBADF,RMS_DIR);
3924     RETPUSHUNDEF;
3925 #else
3926     DIE(aTHX_ PL_no_dir_func, "opendir");
3927 #endif
3928 }
3929
3930 PP(pp_readdir)
3931 {
3932 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3933     DIE(aTHX_ PL_no_dir_func, "readdir");
3934 #else
3935 #if !defined(I_DIRENT) && !defined(VMS)
3936     Direntry_t *readdir (DIR *);
3937 #endif
3938     dVAR;
3939     dSP;
3940
3941     SV *sv;
3942     const I32 gimme = GIMME;
3943     GV * const gv = MUTABLE_GV(POPs);
3944     register const Direntry_t *dp;
3945     register IO * const io = GvIOn(gv);
3946
3947     if (!io || !IoDIRP(io)) {
3948         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3949                        "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3950         goto nope;
3951     }
3952
3953     do {
3954         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3955         if (!dp)
3956             break;
3957 #ifdef DIRNAMLEN
3958         sv = newSVpvn(dp->d_name, dp->d_namlen);
3959 #else
3960         sv = newSVpv(dp->d_name, 0);
3961 #endif
3962 #ifndef INCOMPLETE_TAINTS
3963         if (!(IoFLAGS(io) & IOf_UNTAINT))
3964             SvTAINTED_on(sv);
3965 #endif
3966         mXPUSHs(sv);
3967     } while (gimme == G_ARRAY);
3968
3969     if (!dp && gimme != G_ARRAY)
3970         goto nope;
3971
3972     RETURN;
3973
3974 nope:
3975     if (!errno)
3976         SETERRNO(EBADF,RMS_ISI);
3977     if (GIMME == G_ARRAY)
3978         RETURN;
3979     else
3980         RETPUSHUNDEF;
3981 #endif
3982 }
3983
3984 PP(pp_telldir)
3985 {
3986 #if defined(HAS_TELLDIR) || defined(telldir)
3987     dVAR; dSP; dTARGET;
3988  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3989  /* XXX netbsd still seemed to.
3990     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3991     --JHI 1999-Feb-02 */
3992 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3993     long telldir (DIR *);
3994 # endif
3995     GV * const gv = MUTABLE_GV(POPs);
3996     register IO * const io = GvIOn(gv);
3997
3998     if (!io || !IoDIRP(io)) {
3999         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4000                        "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
4001         goto nope;
4002     }
4003
4004     PUSHi( PerlDir_tell(IoDIRP(io)) );
4005     RETURN;
4006 nope:
4007     if (!errno)
4008         SETERRNO(EBADF,RMS_ISI);
4009     RETPUSHUNDEF;
4010 #else
4011     DIE(aTHX_ PL_no_dir_func, "telldir");
4012 #endif
4013 }
4014
4015 PP(pp_seekdir)
4016 {
4017 #if defined(HAS_SEEKDIR) || defined(seekdir)
4018     dVAR; dSP;
4019     const long along = POPl;
4020     GV * const gv = MUTABLE_GV(POPs);
4021     register IO * const io = GvIOn(gv);
4022
4023     if (!io || !IoDIRP(io)) {
4024         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4025                        "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
4026         goto nope;
4027     }
4028     (void)PerlDir_seek(IoDIRP(io), along);
4029
4030     RETPUSHYES;
4031 nope:
4032     if (!errno)
4033         SETERRNO(EBADF,RMS_ISI);
4034     RETPUSHUNDEF;
4035 #else
4036     DIE(aTHX_ PL_no_dir_func, "seekdir");
4037 #endif
4038 }
4039
4040 PP(pp_rewinddir)
4041 {
4042 #if defined(HAS_REWINDDIR) || defined(rewinddir)
4043     dVAR; dSP;
4044     GV * const gv = MUTABLE_GV(POPs);
4045     register IO * const io = GvIOn(gv);
4046
4047     if (!io || !IoDIRP(io)) {
4048         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4049                        "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
4050         goto nope;
4051     }
4052     (void)PerlDir_rewind(IoDIRP(io));
4053     RETPUSHYES;
4054 nope:
4055     if (!errno)
4056         SETERRNO(EBADF,RMS_ISI);
4057     RETPUSHUNDEF;
4058 #else
4059     DIE(aTHX_ PL_no_dir_func, "rewinddir");
4060 #endif
4061 }
4062
4063 PP(pp_closedir)
4064 {
4065 #if defined(Direntry_t) && defined(HAS_READDIR)
4066     dVAR; dSP;
4067     GV * const gv = MUTABLE_GV(POPs);
4068     register IO * const io = GvIOn(gv);
4069
4070     if (!io || !IoDIRP(io)) {
4071         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
4072                        "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
4073         goto nope;
4074     }
4075 #ifdef VOID_CLOSEDIR
4076     PerlDir_close(IoDIRP(io));
4077 #else
4078     if (PerlDir_close(IoDIRP(io)) < 0) {
4079         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
4080         goto nope;
4081     }
4082 #endif
4083     IoDIRP(io) = 0;
4084
4085     RETPUSHYES;
4086 nope:
4087     if (!errno)
4088         SETERRNO(EBADF,RMS_IFI);
4089     RETPUSHUNDEF;
4090 #else
4091     DIE(aTHX_ PL_no_dir_func, "closedir");
4092 #endif
4093 }
4094
4095 /* Process control. */
4096
4097 PP(pp_fork)
4098 {
4099 #ifdef HAS_FORK
4100     dVAR; dSP; dTARGET;
4101     Pid_t childpid;
4102
4103     EXTEND(SP, 1);
4104     PERL_FLUSHALL_FOR_CHILD;
4105     childpid = PerlProc_fork();
4106     if (childpid < 0)
4107         RETSETUNDEF;
4108     if (!childpid) {
4109         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
4110         if (tmpgv) {
4111             SvREADONLY_off(GvSV(tmpgv));
4112             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
4113             SvREADONLY_on(GvSV(tmpgv));
4114         }
4115 #ifdef THREADS_HAVE_PIDS
4116         PL_ppid = (IV)getppid();
4117 #endif
4118 #ifdef PERL_USES_PL_PIDSTATUS
4119         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4120 #endif
4121     }
4122     PUSHi(childpid);
4123     RETURN;
4124 #else
4125 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4126     dSP; dTARGET;
4127     Pid_t childpid;
4128
4129     EXTEND(SP, 1);
4130     PERL_FLUSHALL_FOR_CHILD;
4131     childpid = PerlProc_fork();
4132     if (childpid == -1)
4133         RETSETUNDEF;
4134     PUSHi(childpid);
4135     RETURN;
4136 #  else
4137     DIE(aTHX_ PL_no_func, "fork");
4138 #  endif
4139 #endif
4140 }
4141
4142 PP(pp_wait)
4143 {
4144 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4145     dVAR; dSP; dTARGET;
4146     Pid_t childpid;
4147     int argflags;
4148
4149     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4150         childpid = wait4pid(-1, &argflags, 0);
4151     else {
4152         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4153                errno == EINTR) {
4154           PERL_ASYNC_CHECK();
4155         }
4156     }
4157 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4158     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4159     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4160 #  else
4161     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4162 #  endif
4163     XPUSHi(childpid);
4164     RETURN;
4165 #else
4166     DIE(aTHX_ PL_no_func, "wait");
4167 #endif
4168 }
4169
4170 PP(pp_waitpid)
4171 {
4172 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4173     dVAR; dSP; dTARGET;
4174     const int optype = POPi;
4175     const Pid_t pid = TOPi;
4176     Pid_t result;
4177     int argflags;
4178
4179     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4180         result = wait4pid(pid, &argflags, optype);
4181     else {
4182         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4183                errno == EINTR) {
4184           PERL_ASYNC_CHECK();
4185         }
4186     }
4187 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4188     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4189     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4190 #  else
4191     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4192 #  endif
4193     SETi(result);
4194     RETURN;
4195 #else
4196     DIE(aTHX_ PL_no_func, "waitpid");
4197 #endif
4198 }
4199
4200 PP(pp_system)
4201 {
4202     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4203 #if defined(__LIBCATAMOUNT__)
4204     PL_statusvalue = -1;
4205     SP = ORIGMARK;
4206     XPUSHi(-1);
4207 #else
4208     I32 value;
4209     int result;
4210
4211     if (PL_tainting) {
4212         TAINT_ENV();
4213         while (++MARK <= SP) {
4214             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4215             if (PL_tainted)
4216                 break;
4217         }
4218         MARK = ORIGMARK;
4219         TAINT_PROPER("system");
4220     }
4221     PERL_FLUSHALL_FOR_CHILD;
4222 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4223     {
4224         Pid_t childpid;
4225         int pp[2];
4226         I32 did_pipes = 0;
4227
4228         if (PerlProc_pipe(pp) >= 0)
4229             did_pipes = 1;
4230         while ((childpid = PerlProc_fork()) == -1) {
4231             if (errno != EAGAIN) {
4232                 value = -1;
4233                 SP = ORIGMARK;
4234                 XPUSHi(value);
4235                 if (did_pipes) {
4236                     PerlLIO_close(pp[0]);
4237                     PerlLIO_close(pp[1]);
4238                 }
4239                 RETURN;
4240             }
4241             sleep(5);
4242         }
4243         if (childpid > 0) {
4244             Sigsave_t ihand,qhand; /* place to save signals during system() */
4245             int status;
4246
4247             if (did_pipes)
4248                 PerlLIO_close(pp[1]);
4249 #ifndef PERL_MICRO
4250             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4251             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4252 #endif
4253             do {
4254                 result = wait4pid(childpid, &status, 0);
4255             } while (result == -1 && errno == EINTR);
4256 #ifndef PERL_MICRO
4257             (void)rsignal_restore(SIGINT, &ihand);
4258             (void)rsignal_restore(SIGQUIT, &qhand);
4259 #endif
4260             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4261             do_execfree();      /* free any memory child malloced on fork */
4262             SP = ORIGMARK;
4263             if (did_pipes) {
4264                 int errkid;
4265                 unsigned n = 0;
4266                 SSize_t n1;
4267
4268                 while (n < sizeof(int)) {
4269                     n1 = PerlLIO_read(pp[0],
4270                                       (void*)(((char*)&errkid)+n),
4271                                       (sizeof(int)) - n);
4272                     if (n1 <= 0)
4273                         break;
4274                     n += n1;
4275                 }
4276                 PerlLIO_close(pp[0]);
4277                 if (n) {                        /* Error */
4278                     if (n != sizeof(int))
4279                         DIE(aTHX_ "panic: kid popen errno read");
4280                     errno = errkid;             /* Propagate errno from kid */
4281                     STATUS_NATIVE_CHILD_SET(-1);
4282                 }
4283             }
4284             XPUSHi(STATUS_CURRENT);
4285             RETURN;
4286         }
4287         if (did_pipes) {
4288             PerlLIO_close(pp[0]);
4289 #if defined(HAS_FCNTL) && defined(F_SETFD)
4290             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4291 #endif
4292         }
4293         if (PL_op->op_flags & OPf_STACKED) {
4294             SV * const really = *++MARK;
4295             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4296         }
4297         else if (SP - MARK != 1)
4298             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4299         else {
4300             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4301         }
4302         PerlProc__exit(-1);
4303     }
4304 #else /* ! FORK or VMS or OS/2 */
4305     PL_statusvalue = 0;
4306     result = 0;
4307     if (PL_op->op_flags & OPf_STACKED) {
4308         SV * const really = *++MARK;
4309 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4310         value = (I32)do_aspawn(really, MARK, SP);
4311 #  else
4312         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4313 #  endif
4314     }
4315     else if (SP - MARK != 1) {
4316 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4317         value = (I32)do_aspawn(NULL, MARK, SP);
4318 #  else
4319         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4320 #  endif
4321     }
4322     else {
4323         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4324     }
4325     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4326         result = 1;
4327     STATUS_NATIVE_CHILD_SET(value);
4328     do_execfree();
4329     SP = ORIGMARK;
4330     XPUSHi(result ? value : STATUS_CURRENT);
4331 #endif /* !FORK or VMS or OS/2 */
4332 #endif
4333     RETURN;
4334 }
4335
4336 PP(pp_exec)
4337 {
4338     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4339     I32 value;
4340
4341     if (PL_tainting) {
4342         TAINT_ENV();
4343         while (++MARK <= SP) {
4344             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4345             if (PL_tainted)
4346                 break;
4347         }
4348         MARK = ORIGMARK;
4349         TAINT_PROPER("exec");
4350     }
4351     PERL_FLUSHALL_FOR_CHILD;
4352     if (PL_op->op_flags & OPf_STACKED) {
4353         SV * const really = *++MARK;
4354         value = (I32)do_aexec(really, MARK, SP);
4355     }
4356     else if (SP - MARK != 1)
4357 #ifdef VMS
4358         value = (I32)vms_do_aexec(NULL, MARK, SP);
4359 #else
4360 #  ifdef __OPEN_VM
4361         {
4362            (void ) do_aspawn(NULL, MARK, SP);
4363            value = 0;
4364         }
4365 #  else
4366         value = (I32)do_aexec(NULL, MARK, SP);
4367 #  endif
4368 #endif
4369     else {
4370 #ifdef VMS
4371         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4372 #else
4373 #  ifdef __OPEN_VM
4374         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4375         value = 0;
4376 #  else
4377         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4378 #  endif
4379 #endif
4380     }
4381
4382     SP = ORIGMARK;
4383     XPUSHi(value);
4384     RETURN;
4385 }
4386
4387 PP(pp_getppid)
4388 {
4389 #ifdef HAS_GETPPID
4390     dVAR; dSP; dTARGET;
4391 #   ifdef THREADS_HAVE_PIDS
4392     if (PL_ppid != 1 && getppid() == 1)
4393         /* maybe the parent process has died. Refresh ppid cache */
4394         PL_ppid = 1;
4395     XPUSHi( PL_ppid );
4396 #   else
4397     XPUSHi( getppid() );
4398 #   endif
4399     RETURN;
4400 #else
4401     DIE(aTHX_ PL_no_func, "getppid");
4402 #endif
4403 }
4404
4405 PP(pp_getpgrp)
4406 {
4407 #ifdef HAS_GETPGRP
4408     dVAR; dSP; dTARGET;
4409     Pid_t pgrp;
4410     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4411
4412 #ifdef BSD_GETPGRP
4413     pgrp = (I32)BSD_GETPGRP(pid);
4414 #else
4415     if (pid != 0 && pid != PerlProc_getpid())
4416         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4417     pgrp = getpgrp();
4418 #endif
4419     XPUSHi(pgrp);
4420     RETURN;
4421 #else
4422     DIE(aTHX_ PL_no_func, "getpgrp()");
4423 #endif
4424 }
4425
4426 PP(pp_setpgrp)
4427 {
4428 #ifdef HAS_SETPGRP
4429     dVAR; dSP; dTARGET;
4430     Pid_t pgrp;
4431     Pid_t pid;
4432     if (MAXARG < 2) {
4433         pgrp = 0;
4434         pid = 0;
4435         XPUSHi(-1);
4436     }
4437     else {
4438         pgrp = POPi;
4439         pid = TOPi;
4440     }
4441
4442     TAINT_PROPER("setpgrp");
4443 #ifdef BSD_SETPGRP
4444     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4445 #else
4446     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4447         || (pid != 0 && pid != PerlProc_getpid()))
4448     {
4449         DIE(aTHX_ "setpgrp can't take arguments");
4450     }
4451     SETi( setpgrp() >= 0 );
4452 #endif /* USE_BSDPGRP */
4453     RETURN;
4454 #else
4455     DIE(aTHX_ PL_no_func, "setpgrp()");
4456 #endif
4457 }
4458
4459 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4460 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4461 #else
4462 #  define PRIORITY_WHICH_T(which) which
4463 #endif
4464
4465 PP(pp_getpriority)
4466 {
4467 #ifdef HAS_GETPRIORITY
4468     dVAR; dSP; dTARGET;
4469     const int who = POPi;
4470     const int which = TOPi;
4471     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4472     RETURN;
4473 #else
4474     DIE(aTHX_ PL_no_func, "getpriority()");
4475 #endif
4476 }
4477
4478 PP(pp_setpriority)
4479 {
4480 #ifdef HAS_SETPRIORITY
4481     dVAR; dSP; dTARGET;
4482     const int niceval = POPi;
4483     const int who = POPi;
4484     const int which = TOPi;
4485     TAINT_PROPER("setpriority");
4486     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4487     RETURN;
4488 #else
4489     DIE(aTHX_ PL_no_func, "setpriority()");
4490 #endif
4491 }
4492
4493 #undef PRIORITY_WHICH_T
4494
4495 /* Time calls. */
4496
4497 PP(pp_time)
4498 {
4499     dVAR; dSP; dTARGET;
4500 #ifdef BIG_TIME
4501     XPUSHn( time(NULL) );
4502 #else
4503     XPUSHi( time(NULL) );
4504 #endif
4505     RETURN;
4506 }
4507
4508 PP(pp_tms)
4509 {
4510 #ifdef HAS_TIMES
4511     dVAR;
4512     dSP;
4513     EXTEND(SP, 4);
4514 #ifndef VMS
4515     (void)PerlProc_times(&PL_timesbuf);
4516 #else
4517     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4518                                                    /* struct tms, though same data   */
4519                                                    /* is returned.                   */
4520 #endif
4521
4522     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4523     if (GIMME == G_ARRAY) {
4524         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4525         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4526         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4527     }
4528     RETURN;
4529 #else
4530 #   ifdef PERL_MICRO
4531     dSP;
4532     mPUSHn(0.0);
4533     EXTEND(SP, 4);
4534     if (GIMME == G_ARRAY) {
4535          mPUSHn(0.0);
4536          mPUSHn(0.0);
4537          mPUSHn(0.0);
4538     }
4539     RETURN;
4540 #   else
4541     DIE(aTHX_ "times not implemented");
4542 #   endif
4543 #endif /* HAS_TIMES */
4544 }
4545
4546 /* The 32 bit int year limits the times we can represent to these
4547    boundaries with a few days wiggle room to account for time zone
4548    offsets
4549 */
4550 /* Sat Jan  3 00:00:00 -2147481748 */
4551 #define TIME_LOWER_BOUND -67768100567755200.0
4552 /* Sun Dec 29 12:00:00  2147483647 */
4553 #define TIME_UPPER_BOUND  67767976233316800.0
4554
4555 PP(pp_gmtime)
4556 {
4557     dVAR;
4558     dSP;
4559     Time64_T when;
4560     struct TM tmbuf;
4561     struct TM *err;
4562     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4563     static const char * const dayname[] =
4564         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4565     static const char * const monname[] =
4566         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4567          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4568
4569     if (MAXARG < 1) {
4570         time_t now;
4571         (void)time(&now);
4572         when = (Time64_T)now;
4573     }
4574     else {
4575         NV input = Perl_floor(POPn);
4576         when = (Time64_T)input;
4577         if (when != input) {
4578             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4579                            "%s(%.0" NVff ") too large", opname, input);
4580         }
4581     }
4582
4583     if ( TIME_LOWER_BOUND > when ) {
4584         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4585                        "%s(%.0" NVff ") too small", opname, when);
4586         err = NULL;
4587     }
4588     else if( when > TIME_UPPER_BOUND ) {
4589         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4590                        "%s(%.0" NVff ") too large", opname, when);
4591         err = NULL;
4592     }
4593     else {
4594         if (PL_op->op_type == OP_LOCALTIME)
4595             err = S_localtime64_r(&when, &tmbuf);
4596         else
4597             err = S_gmtime64_r(&when, &tmbuf);
4598     }
4599
4600     if (err == NULL) {
4601         /* XXX %lld broken for quads */
4602         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4603                        "%s(%.0" NVff ") failed", opname, when);
4604     }
4605
4606     if (GIMME != G_ARRAY) {     /* scalar context */
4607         SV *tsv;
4608         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4609         double year = (double)tmbuf.tm_year + 1900;
4610
4611         EXTEND(SP, 1);
4612         EXTEND_MORTAL(1);
4613         if (err == NULL)
4614             RETPUSHUNDEF;
4615
4616         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4617                             dayname[tmbuf.tm_wday],
4618                             monname[tmbuf.tm_mon],
4619                             tmbuf.tm_mday,
4620                             tmbuf.tm_hour,
4621                             tmbuf.tm_min,
4622                             tmbuf.tm_sec,
4623                             year);
4624         mPUSHs(tsv);
4625     }
4626     else {                      /* list context */
4627         if ( err == NULL )
4628             RETURN;
4629
4630         EXTEND(SP, 9);
4631         EXTEND_MORTAL(9);
4632         mPUSHi(tmbuf.tm_sec);
4633         mPUSHi(tmbuf.tm_min);
4634         mPUSHi(tmbuf.tm_hour);
4635         mPUSHi(tmbuf.tm_mday);
4636         mPUSHi(tmbuf.tm_mon);
4637         mPUSHn(tmbuf.tm_year);
4638         mPUSHi(tmbuf.tm_wday);
4639         mPUSHi(tmbuf.tm_yday);
4640         mPUSHi(tmbuf.tm_isdst);
4641     }
4642     RETURN;
4643 }
4644
4645 PP(pp_alarm)
4646 {
4647 #ifdef HAS_ALARM
4648     dVAR; dSP; dTARGET;
4649     int anum;
4650     anum = POPi;
4651     anum = alarm((unsigned int)anum);
4652     if (anum < 0)
4653         RETPUSHUNDEF;
4654     PUSHi(anum);
4655     RETURN;
4656 #else
4657     DIE(aTHX_ PL_no_func, "alarm");
4658 #endif
4659 }
4660
4661 PP(pp_sleep)
4662 {
4663     dVAR; dSP; dTARGET;
4664     I32 duration;
4665     Time_t lasttime;
4666     Time_t when;
4667
4668     (void)time(&lasttime);
4669     if (MAXARG < 1)
4670         PerlProc_pause();
4671     else {
4672         duration = POPi;
4673         PerlProc_sleep((unsigned int)duration);
4674     }
4675     (void)time(&when);
4676     XPUSHi(when - lasttime);
4677     RETURN;
4678 }
4679
4680 /* Shared memory. */
4681 /* Merged with some message passing. */
4682
4683 PP(pp_shmwrite)
4684 {
4685 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4686     dVAR; dSP; dMARK; dTARGET;
4687     const int op_type = PL_op->op_type;
4688     I32 value;
4689
4690     switch (op_type) {
4691     case OP_MSGSND:
4692         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4693         break;
4694     case OP_MSGRCV:
4695         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4696         break;
4697     case OP_SEMOP:
4698         value = (I32)(do_semop(MARK, SP) >= 0);
4699         break;
4700     default:
4701         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4702         break;
4703     }
4704
4705     SP = MARK;
4706     PUSHi(value);
4707     RETURN;
4708 #else
4709     return pp_semget();
4710 #endif
4711 }
4712
4713 /* Semaphores. */
4714
4715 PP(pp_semget)
4716 {
4717 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4718     dVAR; dSP; dMARK; dTARGET;
4719     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4720     SP = MARK;
4721     if (anum == -1)
4722         RETPUSHUNDEF;
4723     PUSHi(anum);
4724     RETURN;
4725 #else
4726     DIE(aTHX_ "System V IPC is not implemented on this machine");
4727 #endif
4728 }
4729
4730 PP(pp_semctl)
4731 {
4732 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4733     dVAR; dSP; dMARK; dTARGET;
4734     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4735     SP = MARK;
4736     if (anum == -1)
4737         RETSETUNDEF;
4738     if (anum != 0) {
4739         PUSHi(anum);
4740     }
4741     else {
4742         PUSHp(zero_but_true, ZBTLEN);
4743     }
4744     RETURN;
4745 #else
4746     return pp_semget();
4747 #endif
4748 }
4749
4750 /* I can't const this further without getting warnings about the types of
4751    various arrays passed in from structures.  */
4752 static SV *
4753 S_space_join_names_mortal(pTHX_ char *const *array)
4754 {
4755     SV *target;
4756
4757     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4758
4759     if (array && *array) {
4760         target = newSVpvs_flags("", SVs_TEMP);
4761         while (1) {
4762             sv_catpv(target, *array);
4763             if (!*++array)
4764                 break;
4765             sv_catpvs(target, " ");
4766         }
4767     } else {
4768         target = sv_mortalcopy(&PL_sv_no);
4769     }
4770     return target;
4771 }
4772
4773 /* Get system info. */
4774
4775 PP(pp_ghostent)
4776 {
4777 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4778     dVAR; dSP;
4779     I32 which = PL_op->op_type;
4780     register char **elem;
4781     register SV *sv;
4782 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4783     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4784     struct hostent *gethostbyname(Netdb_name_t);
4785     struct hostent *gethostent(void);
4786 #endif
4787     struct hostent *hent = NULL;
4788     unsigned long len;
4789
4790     EXTEND(SP, 10);
4791     if (which == OP_GHBYNAME) {
4792 #ifdef HAS_GETHOSTBYNAME
4793         const char* const name = POPpbytex;
4794         hent = PerlSock_gethostbyname(name);
4795 #else
4796         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4797 #endif
4798     }
4799     else if (which == OP_GHBYADDR) {
4800 #ifdef HAS_GETHOSTBYADDR
4801         const int addrtype = POPi;
4802         SV * const addrsv = POPs;
4803         STRLEN addrlen;
4804         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4805
4806         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4807 #else
4808         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4809 #endif
4810     }
4811     else
4812 #ifdef HAS_GETHOSTENT
4813         hent = PerlSock_gethostent();
4814 #else
4815         DIE(aTHX_ PL_no_sock_func, "gethostent");
4816 #endif
4817
4818 #ifdef HOST_NOT_FOUND
4819         if (!hent) {
4820 #ifdef USE_REENTRANT_API
4821 #   ifdef USE_GETHOSTENT_ERRNO
4822             h_errno = PL_reentrant_buffer->_gethostent_errno;
4823 #   endif
4824 #endif
4825             STATUS_UNIX_SET(h_errno);
4826         }
4827 #endif
4828
4829     if (GIMME != G_ARRAY) {
4830         PUSHs(sv = sv_newmortal());
4831         if (hent) {
4832             if (which == OP_GHBYNAME) {
4833                 if (hent->h_addr)
4834                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4835             }
4836             else
4837                 sv_setpv(sv, (char*)hent->h_name);
4838         }
4839         RETURN;
4840     }
4841
4842     if (hent) {
4843         mPUSHs(newSVpv((char*)hent->h_name, 0));
4844         PUSHs(space_join_names_mortal(hent->h_aliases));
4845         mPUSHi(hent->h_addrtype);
4846         len = hent->h_length;
4847         mPUSHi(len);
4848 #ifdef h_addr
4849         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4850             mXPUSHp(*elem, len);
4851         }
4852 #else
4853         if (hent->h_addr)
4854             mPUSHp(hent->h_addr, len);
4855         else
4856             PUSHs(sv_mortalcopy(&PL_sv_no));
4857 #endif /* h_addr */
4858     }
4859     RETURN;
4860 #else
4861     DIE(aTHX_ PL_no_sock_func, "gethostent");
4862 #endif
4863 }
4864
4865 PP(pp_gnetent)
4866 {
4867 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4868     dVAR; dSP;
4869     I32 which = PL_op->op_type;
4870     register SV *sv;
4871 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4872     struct netent *getnetbyaddr(Netdb_net_t, int);
4873     struct netent *getnetbyname(Netdb_name_t);
4874     struct netent *getnetent(void);
4875 #endif
4876     struct netent *nent;
4877
4878     if (which == OP_GNBYNAME){
4879 #ifdef HAS_GETNETBYNAME
4880         const char * const name = POPpbytex;
4881         nent = PerlSock_getnetbyname(name);
4882 #else
4883         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4884 #endif
4885     }
4886     else if (which == OP_GNBYADDR) {
4887 #ifdef HAS_GETNETBYADDR
4888         const int addrtype = POPi;
4889         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4890         nent = PerlSock_getnetbyaddr(addr, addrtype);
4891 #else
4892         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4893 #endif
4894     }
4895     else
4896 #ifdef HAS_GETNETENT
4897         nent = PerlSock_getnetent();
4898 #else
4899         DIE(aTHX_ PL_no_sock_func, "getnetent");
4900 #endif
4901
4902 #ifdef HOST_NOT_FOUND
4903         if (!nent) {
4904 #ifdef USE_REENTRANT_API
4905 #   ifdef USE_GETNETENT_ERRNO
4906              h_errno = PL_reentrant_buffer->_getnetent_errno;
4907 #   endif
4908 #endif
4909             STATUS_UNIX_SET(h_errno);
4910         }
4911 #endif
4912
4913     EXTEND(SP, 4);
4914     if (GIMME != G_ARRAY) {
4915         PUSHs(sv = sv_newmortal());
4916         if (nent) {
4917             if (which == OP_GNBYNAME)
4918                 sv_setiv(sv, (IV)nent->n_net);
4919             else
4920                 sv_setpv(sv, nent->n_name);
4921         }
4922         RETURN;
4923     }
4924
4925     if (nent) {
4926         mPUSHs(newSVpv(nent->n_name, 0));
4927         PUSHs(space_join_names_mortal(nent->n_aliases));
4928         mPUSHi(nent->n_addrtype);
4929         mPUSHi(nent->n_net);
4930     }
4931
4932     RETURN;
4933 #else
4934     DIE(aTHX_ PL_no_sock_func, "getnetent");
4935 #endif
4936 }
4937
4938 PP(pp_gprotoent)
4939 {
4940 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4941     dVAR; dSP;
4942     I32 which = PL_op->op_type;
4943     register SV *sv;
4944 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4945     struct protoent *getprotobyname(Netdb_name_t);
4946     struct protoent *getprotobynumber(int);
4947     struct protoent *getprotoent(void);
4948 #endif
4949     struct protoent *pent;
4950
4951     if (which == OP_GPBYNAME) {
4952 #ifdef HAS_GETPROTOBYNAME
4953         const char* const name = POPpbytex;
4954         pent = PerlSock_getprotobyname(name);
4955 #else
4956         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4957 #endif
4958     }
4959     else if (which == OP_GPBYNUMBER) {
4960 #ifdef HAS_GETPROTOBYNUMBER
4961         const int number = POPi;
4962         pent = PerlSock_getprotobynumber(number);
4963 #else
4964         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4965 #endif
4966     }
4967     else
4968 #ifdef HAS_GETPROTOENT
4969         pent = PerlSock_getprotoent();
4970 #else
4971         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4972 #endif
4973
4974     EXTEND(SP, 3);
4975     if (GIMME != G_ARRAY) {
4976         PUSHs(sv = sv_newmortal());
4977         if (pent) {
4978             if (which == OP_GPBYNAME)
4979                 sv_setiv(sv, (IV)pent->p_proto);
4980             else
4981                 sv_setpv(sv, pent->p_name);
4982         }
4983         RETURN;
4984     }
4985
4986     if (pent) {
4987         mPUSHs(newSVpv(pent->p_name, 0));
4988         PUSHs(space_join_names_mortal(pent->p_aliases));
4989         mPUSHi(pent->p_proto);
4990     }
4991
4992     RETURN;
4993 #else
4994     DIE(aTHX_ PL_no_sock_func, "getprotoent");
4995 #endif
4996 }
4997
4998 PP(pp_gservent)
4999 {
5000 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
5001     dVAR; dSP;
5002     I32 which = PL_op->op_type;
5003     register SV *sv;
5004 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
5005     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
5006     struct servent *getservbyport(int, Netdb_name_t);
5007     struct servent *getservent(void);
5008 #endif
5009     struct servent *sent;
5010
5011     if (which == OP_GSBYNAME) {
5012 #ifdef HAS_GETSERVBYNAME
5013         const char * const proto = POPpbytex;
5014         const char * const name = POPpbytex;
5015         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
5016 #else
5017         DIE(aTHX_ PL_no_sock_func, "getservbyname");
5018 #endif
5019     }
5020     else if (which == OP_GSBYPORT) {
5021 #ifdef HAS_GETSERVBYPORT
5022         const char * const proto = POPpbytex;
5023         unsigned short port = (unsigned short)POPu;
5024 #ifdef HAS_HTONS
5025         port = PerlSock_htons(port);
5026 #endif
5027         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
5028 #else
5029         DIE(aTHX_ PL_no_sock_func, "getservbyport");
5030 #endif
5031     }
5032     else
5033 #ifdef HAS_GETSERVENT
5034         sent = PerlSock_getservent();
5035 #else
5036         DIE(aTHX_ PL_no_sock_func, "getservent");
5037 #endif
5038
5039     EXTEND(SP, 4);
5040     if (GIMME != G_ARRAY) {
5041         PUSHs(sv = sv_newmortal());
5042         if (sent) {
5043             if (which == OP_GSBYNAME) {
5044 #ifdef HAS_NTOHS
5045                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
5046 #else
5047                 sv_setiv(sv, (IV)(sent->s_port));
5048 #endif
5049             }
5050             else
5051                 sv_setpv(sv, sent->s_name);
5052         }
5053         RETURN;
5054     }
5055
5056     if (sent) {
5057         mPUSHs(newSVpv(sent->s_name, 0));
5058         PUSHs(space_join_names_mortal(sent->s_aliases));
5059 #ifdef HAS_NTOHS