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