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