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