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