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