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