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