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