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