This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make filetest ops handle get-magic correctly for glob(ref)s
[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         int result = 1;
2192         GV *tmpgv;
2193         IO *io;
2194
2195         if (PL_op->op_flags & OPf_SPECIAL) {
2196             tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2197
2198         do_ftruncate_gv:
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 {
2221             SV * const sv = POPs;
2222             const char *name;
2223
2224             if (isGV_with_GP(sv)) {
2225                 tmpgv = MUTABLE_GV(sv);         /* *main::FRED for example */
2226                 goto do_ftruncate_gv;
2227             }
2228             else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2229                 tmpgv = MUTABLE_GV(SvRV(sv));   /* \*main::FRED for example */
2230                 goto do_ftruncate_gv;
2231             }
2232             else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2233                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2234                 goto do_ftruncate_io;
2235             }
2236
2237             name = SvPV_nolen_const(sv);
2238             TAINT_PROPER("truncate");
2239 #ifdef HAS_TRUNCATE
2240             if (truncate(name, len) < 0)
2241                 result = 0;
2242 #else
2243             {
2244                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2245
2246                 if (tmpfd < 0)
2247                     result = 0;
2248                 else {
2249                     if (my_chsize(tmpfd, len) < 0)
2250                         result = 0;
2251                     PerlLIO_close(tmpfd);
2252                 }
2253             }
2254 #endif
2255         }
2256
2257         if (result)
2258             RETPUSHYES;
2259         if (!errno)
2260             SETERRNO(EBADF,RMS_IFI);
2261         RETPUSHUNDEF;
2262     }
2263 }
2264
2265 PP(pp_ioctl)
2266 {
2267     dVAR; dSP; dTARGET;
2268     SV * const argsv = POPs;
2269     const unsigned int func = POPu;
2270     const int optype = PL_op->op_type;
2271     GV * const gv = MUTABLE_GV(POPs);
2272     IO * const io = gv ? GvIOn(gv) : NULL;
2273     char *s;
2274     IV retval;
2275
2276     if (!io || !argsv || !IoIFP(io)) {
2277         report_evil_fh(gv);
2278         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2279         RETPUSHUNDEF;
2280     }
2281
2282     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2283         STRLEN len;
2284         STRLEN need;
2285         s = SvPV_force(argsv, len);
2286         need = IOCPARM_LEN(func);
2287         if (len < need) {
2288             s = Sv_Grow(argsv, need + 1);
2289             SvCUR_set(argsv, need);
2290         }
2291
2292         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2293     }
2294     else {
2295         retval = SvIV(argsv);
2296         s = INT2PTR(char*,retval);              /* ouch */
2297     }
2298
2299     TAINT_PROPER(PL_op_desc[optype]);
2300
2301     if (optype == OP_IOCTL)
2302 #ifdef HAS_IOCTL
2303         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2304 #else
2305         DIE(aTHX_ "ioctl is not implemented");
2306 #endif
2307     else
2308 #ifndef HAS_FCNTL
2309       DIE(aTHX_ "fcntl is not implemented");
2310 #else
2311 #if defined(OS2) && defined(__EMX__)
2312         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2313 #else
2314         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2315 #endif
2316 #endif
2317
2318 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2319     if (SvPOK(argsv)) {
2320         if (s[SvCUR(argsv)] != 17)
2321             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2322                 OP_NAME(PL_op));
2323         s[SvCUR(argsv)] = 0;            /* put our null back */
2324         SvSETMAGIC(argsv);              /* Assume it has changed */
2325     }
2326
2327     if (retval == -1)
2328         RETPUSHUNDEF;
2329     if (retval != 0) {
2330         PUSHi(retval);
2331     }
2332     else {
2333         PUSHp(zero_but_true, ZBTLEN);
2334     }
2335 #endif
2336     RETURN;
2337 }
2338
2339 PP(pp_flock)
2340 {
2341 #ifdef FLOCK
2342     dVAR; dSP; dTARGET;
2343     I32 value;
2344     const int argtype = POPi;
2345     GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2346     IO *const io = GvIO(gv);
2347     PerlIO *const fp = io ? IoIFP(io) : NULL;
2348
2349     /* XXX Looks to me like io is always NULL at this point */
2350     if (fp) {
2351         (void)PerlIO_flush(fp);
2352         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2353     }
2354     else {
2355         report_evil_fh(gv);
2356         value = 0;
2357         SETERRNO(EBADF,RMS_IFI);
2358     }
2359     PUSHi(value);
2360     RETURN;
2361 #else
2362     DIE(aTHX_ PL_no_func, "flock()");
2363 #endif
2364 }
2365
2366 /* Sockets. */
2367
2368 #ifdef HAS_SOCKET
2369
2370 PP(pp_socket)
2371 {
2372     dVAR; dSP;
2373     const int protocol = POPi;
2374     const int type = POPi;
2375     const int domain = POPi;
2376     GV * const gv = MUTABLE_GV(POPs);
2377     register IO * const io = gv ? GvIOn(gv) : NULL;
2378     int fd;
2379
2380     if (!io) {
2381         report_evil_fh(gv);
2382         if (io && IoIFP(io))
2383             do_close(gv, FALSE);
2384         SETERRNO(EBADF,LIB_INVARG);
2385         RETPUSHUNDEF;
2386     }
2387
2388     if (IoIFP(io))
2389         do_close(gv, FALSE);
2390
2391     TAINT_PROPER("socket");
2392     fd = PerlSock_socket(domain, type, protocol);
2393     if (fd < 0)
2394         RETPUSHUNDEF;
2395     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2396     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2397     IoTYPE(io) = IoTYPE_SOCKET;
2398     if (!IoIFP(io) || !IoOFP(io)) {
2399         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2400         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2401         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2402         RETPUSHUNDEF;
2403     }
2404 #if defined(HAS_FCNTL) && defined(F_SETFD)
2405     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2406 #endif
2407
2408 #ifdef EPOC
2409     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2410 #endif
2411
2412     RETPUSHYES;
2413 }
2414 #endif
2415
2416 PP(pp_sockpair)
2417 {
2418 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2419     dVAR; dSP;
2420     const int protocol = POPi;
2421     const int type = POPi;
2422     const int domain = POPi;
2423     GV * const gv2 = MUTABLE_GV(POPs);
2424     GV * const gv1 = MUTABLE_GV(POPs);
2425     register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2426     register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2427     int fd[2];
2428
2429     if (!io1)
2430         report_evil_fh(gv1);
2431     if (!io2)
2432         report_evil_fh(gv2);
2433
2434     if (io1 && IoIFP(io1))
2435         do_close(gv1, FALSE);
2436     if (io2 && IoIFP(io2))
2437         do_close(gv2, FALSE);
2438
2439     if (!io1 || !io2)
2440         RETPUSHUNDEF;
2441
2442     TAINT_PROPER("socketpair");
2443     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2444         RETPUSHUNDEF;
2445     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2446     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2447     IoTYPE(io1) = IoTYPE_SOCKET;
2448     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2449     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2450     IoTYPE(io2) = IoTYPE_SOCKET;
2451     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2452         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2453         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2454         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2455         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2456         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2457         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2458         RETPUSHUNDEF;
2459     }
2460 #if defined(HAS_FCNTL) && defined(F_SETFD)
2461     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2462     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2463 #endif
2464
2465     RETPUSHYES;
2466 #else
2467     DIE(aTHX_ PL_no_sock_func, "socketpair");
2468 #endif
2469 }
2470
2471 #ifdef HAS_SOCKET
2472
2473 PP(pp_bind)
2474 {
2475     dVAR; dSP;
2476     SV * const addrsv = POPs;
2477     /* OK, so on what platform does bind modify addr?  */
2478     const char *addr;
2479     GV * const gv = MUTABLE_GV(POPs);
2480     register IO * const io = GvIOn(gv);
2481     STRLEN len;
2482     const int op_type = PL_op->op_type;
2483
2484     if (!io || !IoIFP(io))
2485         goto nuts;
2486
2487     addr = SvPV_const(addrsv, len);
2488     TAINT_PROPER(PL_op_desc[op_type]);
2489     if ((op_type == OP_BIND
2490          ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2491          : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2492         >= 0)
2493         RETPUSHYES;
2494     else
2495         RETPUSHUNDEF;
2496
2497 nuts:
2498     report_evil_fh(gv);
2499     SETERRNO(EBADF,SS_IVCHAN);
2500     RETPUSHUNDEF;
2501 }
2502
2503 PP(pp_listen)
2504 {
2505     dVAR; dSP;
2506     const int backlog = POPi;
2507     GV * const gv = MUTABLE_GV(POPs);
2508     register IO * const io = gv ? GvIOn(gv) : NULL;
2509
2510     if (!io || !IoIFP(io))
2511         goto nuts;
2512
2513     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2514         RETPUSHYES;
2515     else
2516         RETPUSHUNDEF;
2517
2518 nuts:
2519     report_evil_fh(gv);
2520     SETERRNO(EBADF,SS_IVCHAN);
2521     RETPUSHUNDEF;
2522 }
2523
2524 PP(pp_accept)
2525 {
2526     dVAR; dSP; dTARGET;
2527     register IO *nstio;
2528     register IO *gstio;
2529     char namebuf[MAXPATHLEN];
2530 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2531     Sock_size_t len = sizeof (struct sockaddr_in);
2532 #else
2533     Sock_size_t len = sizeof namebuf;
2534 #endif
2535     GV * const ggv = MUTABLE_GV(POPs);
2536     GV * const ngv = MUTABLE_GV(POPs);
2537     int fd;
2538
2539     if (!ngv)
2540         goto badexit;
2541     if (!ggv)
2542         goto nuts;
2543
2544     gstio = GvIO(ggv);
2545     if (!gstio || !IoIFP(gstio))
2546         goto nuts;
2547
2548     nstio = GvIOn(ngv);
2549     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2550 #if defined(OEMVS)
2551     if (len == 0) {
2552         /* Some platforms indicate zero length when an AF_UNIX client is
2553          * not bound. Simulate a non-zero-length sockaddr structure in
2554          * this case. */
2555         namebuf[0] = 0;        /* sun_len */
2556         namebuf[1] = AF_UNIX;  /* sun_family */
2557         len = 2;
2558     }
2559 #endif
2560
2561     if (fd < 0)
2562         goto badexit;
2563     if (IoIFP(nstio))
2564         do_close(ngv, FALSE);
2565     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2566     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2567     IoTYPE(nstio) = IoTYPE_SOCKET;
2568     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2569         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2570         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2571         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2572         goto badexit;
2573     }
2574 #if defined(HAS_FCNTL) && defined(F_SETFD)
2575     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2576 #endif
2577
2578 #ifdef EPOC
2579     len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2580     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2581 #endif
2582 #ifdef __SCO_VERSION__
2583     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2584 #endif
2585
2586     PUSHp(namebuf, len);
2587     RETURN;
2588
2589 nuts:
2590     report_evil_fh(ggv);
2591     SETERRNO(EBADF,SS_IVCHAN);
2592
2593 badexit:
2594     RETPUSHUNDEF;
2595
2596 }
2597
2598 PP(pp_shutdown)
2599 {
2600     dVAR; dSP; dTARGET;
2601     const int how = POPi;
2602     GV * const gv = MUTABLE_GV(POPs);
2603     register IO * const io = GvIOn(gv);
2604
2605     if (!io || !IoIFP(io))
2606         goto nuts;
2607
2608     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2609     RETURN;
2610
2611 nuts:
2612     report_evil_fh(gv);
2613     SETERRNO(EBADF,SS_IVCHAN);
2614     RETPUSHUNDEF;
2615 }
2616
2617 PP(pp_ssockopt)
2618 {
2619     dVAR; dSP;
2620     const int optype = PL_op->op_type;
2621     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2622     const unsigned int optname = (unsigned int) POPi;
2623     const unsigned int lvl = (unsigned int) POPi;
2624     GV * const gv = MUTABLE_GV(POPs);
2625     register IO * const io = GvIOn(gv);
2626     int fd;
2627     Sock_size_t len;
2628
2629     if (!io || !IoIFP(io))
2630         goto nuts;
2631
2632     fd = PerlIO_fileno(IoIFP(io));
2633     switch (optype) {
2634     case OP_GSOCKOPT:
2635         SvGROW(sv, 257);
2636         (void)SvPOK_only(sv);
2637         SvCUR_set(sv,256);
2638         *SvEND(sv) ='\0';
2639         len = SvCUR(sv);
2640         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2641             goto nuts2;
2642         SvCUR_set(sv, len);
2643         *SvEND(sv) ='\0';
2644         PUSHs(sv);
2645         break;
2646     case OP_SSOCKOPT: {
2647 #if defined(__SYMBIAN32__)
2648 # define SETSOCKOPT_OPTION_VALUE_T void *
2649 #else
2650 # define SETSOCKOPT_OPTION_VALUE_T const char *
2651 #endif
2652         /* XXX TODO: We need to have a proper type (a Configure probe,
2653          * etc.) for what the C headers think of the third argument of
2654          * setsockopt(), the option_value read-only buffer: is it
2655          * a "char *", or a "void *", const or not.  Some compilers
2656          * don't take kindly to e.g. assuming that "char *" implicitly
2657          * promotes to a "void *", or to explicitly promoting/demoting
2658          * consts to non/vice versa.  The "const void *" is the SUS
2659          * definition, but that does not fly everywhere for the above
2660          * reasons. */
2661             SETSOCKOPT_OPTION_VALUE_T buf;
2662             int aint;
2663             if (SvPOKp(sv)) {
2664                 STRLEN l;
2665                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2666                 len = l;
2667             }
2668             else {
2669                 aint = (int)SvIV(sv);
2670                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2671                 len = sizeof(int);
2672             }
2673             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2674                 goto nuts2;
2675             PUSHs(&PL_sv_yes);
2676         }
2677         break;
2678     }
2679     RETURN;
2680
2681 nuts:
2682     report_evil_fh(gv);
2683     SETERRNO(EBADF,SS_IVCHAN);
2684 nuts2:
2685     RETPUSHUNDEF;
2686
2687 }
2688
2689 PP(pp_getpeername)
2690 {
2691     dVAR; dSP;
2692     const int optype = PL_op->op_type;
2693     GV * const gv = MUTABLE_GV(POPs);
2694     register IO * const io = GvIOn(gv);
2695     Sock_size_t len;
2696     SV *sv;
2697     int fd;
2698
2699     if (!io || !IoIFP(io))
2700         goto nuts;
2701
2702     sv = sv_2mortal(newSV(257));
2703     (void)SvPOK_only(sv);
2704     len = 256;
2705     SvCUR_set(sv, len);
2706     *SvEND(sv) ='\0';
2707     fd = PerlIO_fileno(IoIFP(io));
2708     switch (optype) {
2709     case OP_GETSOCKNAME:
2710         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2711             goto nuts2;
2712         break;
2713     case OP_GETPEERNAME:
2714         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2715             goto nuts2;
2716 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2717         {
2718             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";
2719             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2720             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2721                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2722                         sizeof(u_short) + sizeof(struct in_addr))) {
2723                 goto nuts2;     
2724             }
2725         }
2726 #endif
2727         break;
2728     }
2729 #ifdef BOGUS_GETNAME_RETURN
2730     /* Interactive Unix, getpeername() and getsockname()
2731       does not return valid namelen */
2732     if (len == BOGUS_GETNAME_RETURN)
2733         len = sizeof(struct sockaddr);
2734 #endif
2735     SvCUR_set(sv, len);
2736     *SvEND(sv) ='\0';
2737     PUSHs(sv);
2738     RETURN;
2739
2740 nuts:
2741     report_evil_fh(gv);
2742     SETERRNO(EBADF,SS_IVCHAN);
2743 nuts2:
2744     RETPUSHUNDEF;
2745 }
2746
2747 #endif
2748
2749 /* Stat calls. */
2750
2751 PP(pp_stat)
2752 {
2753     dVAR;
2754     dSP;
2755     GV *gv = NULL;
2756     IO *io;
2757     I32 gimme;
2758     I32 max = 13;
2759
2760     if (PL_op->op_flags & OPf_REF) {
2761         gv = cGVOP_gv;
2762         if (PL_op->op_type == OP_LSTAT) {
2763             if (gv != PL_defgv) {
2764             do_fstat_warning_check:
2765                 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2766                                "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2767             } else if (PL_laststype != OP_LSTAT)
2768                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2769         }
2770
2771       do_fstat:
2772         if (gv != PL_defgv) {
2773             PL_laststype = OP_STAT;
2774             PL_statgv = gv;
2775             sv_setpvs(PL_statname, "");
2776             if(gv) {
2777                 io = GvIO(gv);
2778                 do_fstat_have_io:
2779                 if (io) {
2780                     if (IoIFP(io)) {
2781                         PL_laststatval = 
2782                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
2783                     } else if (IoDIRP(io)) {
2784                         PL_laststatval =
2785                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2786                     } else {
2787                         PL_laststatval = -1;
2788                     }
2789                 }
2790             }
2791         }
2792
2793         if (PL_laststatval < 0) {
2794             report_evil_fh(gv);
2795             max = 0;
2796         }
2797     }
2798     else {
2799         SV* const sv = POPs;
2800         if (isGV_with_GP(sv)) {
2801             gv = MUTABLE_GV(sv);
2802             goto do_fstat;
2803         } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2804             gv = MUTABLE_GV(SvRV(sv));
2805             if (PL_op->op_type == OP_LSTAT)
2806                 goto do_fstat_warning_check;
2807             goto do_fstat;
2808         } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
2809             io = MUTABLE_IO(SvRV(sv));
2810             if (PL_op->op_type == OP_LSTAT)
2811                 goto do_fstat_warning_check;
2812             goto do_fstat_have_io; 
2813         }
2814         
2815         sv_setpv(PL_statname, SvPV_nolen_const(sv));
2816         PL_statgv = NULL;
2817         PL_laststype = PL_op->op_type;
2818         if (PL_op->op_type == OP_LSTAT)
2819             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2820         else
2821             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2822         if (PL_laststatval < 0) {
2823             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2824                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2825             max = 0;
2826         }
2827     }
2828
2829     gimme = GIMME_V;
2830     if (gimme != G_ARRAY) {
2831         if (gimme != G_VOID)
2832             XPUSHs(boolSV(max));
2833         RETURN;
2834     }
2835     if (max) {
2836         EXTEND(SP, max);
2837         EXTEND_MORTAL(max);
2838         mPUSHi(PL_statcache.st_dev);
2839 #if ST_INO_SIZE > IVSIZE
2840         mPUSHn(PL_statcache.st_ino);
2841 #else
2842 #   if ST_INO_SIGN <= 0
2843         mPUSHi(PL_statcache.st_ino);
2844 #   else
2845         mPUSHu(PL_statcache.st_ino);
2846 #   endif
2847 #endif
2848         mPUSHu(PL_statcache.st_mode);
2849         mPUSHu(PL_statcache.st_nlink);
2850 #if Uid_t_size > IVSIZE
2851         mPUSHn(PL_statcache.st_uid);
2852 #else
2853 #   if Uid_t_sign <= 0
2854         mPUSHi(PL_statcache.st_uid);
2855 #   else
2856         mPUSHu(PL_statcache.st_uid);
2857 #   endif
2858 #endif
2859 #if Gid_t_size > IVSIZE
2860         mPUSHn(PL_statcache.st_gid);
2861 #else
2862 #   if Gid_t_sign <= 0
2863         mPUSHi(PL_statcache.st_gid);
2864 #   else
2865         mPUSHu(PL_statcache.st_gid);
2866 #   endif
2867 #endif
2868 #ifdef USE_STAT_RDEV
2869         mPUSHi(PL_statcache.st_rdev);
2870 #else
2871         PUSHs(newSVpvs_flags("", SVs_TEMP));
2872 #endif
2873 #if Off_t_size > IVSIZE
2874         mPUSHn(PL_statcache.st_size);
2875 #else
2876         mPUSHi(PL_statcache.st_size);
2877 #endif
2878 #ifdef BIG_TIME
2879         mPUSHn(PL_statcache.st_atime);
2880         mPUSHn(PL_statcache.st_mtime);
2881         mPUSHn(PL_statcache.st_ctime);
2882 #else
2883         mPUSHi(PL_statcache.st_atime);
2884         mPUSHi(PL_statcache.st_mtime);
2885         mPUSHi(PL_statcache.st_ctime);
2886 #endif
2887 #ifdef USE_STAT_BLOCKS
2888         mPUSHu(PL_statcache.st_blksize);
2889         mPUSHu(PL_statcache.st_blocks);
2890 #else
2891         PUSHs(newSVpvs_flags("", SVs_TEMP));
2892         PUSHs(newSVpvs_flags("", SVs_TEMP));
2893 #endif
2894     }
2895     RETURN;
2896 }
2897
2898 #define tryAMAGICftest_MG(chr) STMT_START { \
2899         if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2900                 && S_try_amagic_ftest(aTHX_ chr)) \
2901             return NORMAL; \
2902     } STMT_END
2903
2904 STATIC bool
2905 S_try_amagic_ftest(pTHX_ char chr) {
2906     dVAR;
2907     dSP;
2908     SV* const arg = TOPs;
2909
2910     assert(chr != '?');
2911     SvGETMAGIC(arg);
2912
2913     if ((PL_op->op_flags & OPf_KIDS)
2914             && SvAMAGIC(TOPs))
2915     {
2916         const char tmpchr = chr;
2917         SV * const tmpsv = amagic_call(arg,
2918                                 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2919                                 ftest_amg, AMGf_unary);
2920
2921         if (!tmpsv)
2922             return FALSE;
2923
2924         SPAGAIN;
2925
2926         if (PL_op->op_private & OPpFT_STACKING) {
2927             if (SvTRUE(tmpsv))
2928                 /* leave the object alone */
2929                 return TRUE;
2930         }
2931
2932         SETs(tmpsv);
2933         PUTBACK;
2934         return TRUE;
2935     }
2936     return FALSE;
2937 }
2938
2939
2940 /* This macro is used by the stacked filetest operators :
2941  * if the previous filetest failed, short-circuit and pass its value.
2942  * Else, discard it from the stack and continue. --rgs
2943  */
2944 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2945         if (!SvTRUE(TOPs)) { RETURN; } \
2946         else { (void)POPs; PUTBACK; } \
2947     }
2948
2949 PP(pp_ftrread)
2950 {
2951     dVAR;
2952     I32 result;
2953     /* Not const, because things tweak this below. Not bool, because there's
2954        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2955 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2956     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2957     /* Giving some sort of initial value silences compilers.  */
2958 #  ifdef R_OK
2959     int access_mode = R_OK;
2960 #  else
2961     int access_mode = 0;
2962 #  endif
2963 #else
2964     /* access_mode is never used, but leaving use_access in makes the
2965        conditional compiling below much clearer.  */
2966     I32 use_access = 0;
2967 #endif
2968     Mode_t stat_mode = S_IRUSR;
2969
2970     bool effective = FALSE;
2971     char opchar = '?';
2972     dSP;
2973
2974     switch (PL_op->op_type) {
2975     case OP_FTRREAD:    opchar = 'R'; break;
2976     case OP_FTRWRITE:   opchar = 'W'; break;
2977     case OP_FTREXEC:    opchar = 'X'; break;
2978     case OP_FTEREAD:    opchar = 'r'; break;
2979     case OP_FTEWRITE:   opchar = 'w'; break;
2980     case OP_FTEEXEC:    opchar = 'x'; break;
2981     }
2982     tryAMAGICftest_MG(opchar);
2983
2984     STACKED_FTEST_CHECK;
2985
2986     switch (PL_op->op_type) {
2987     case OP_FTRREAD:
2988 #if !(defined(HAS_ACCESS) && defined(R_OK))
2989         use_access = 0;
2990 #endif
2991         break;
2992
2993     case OP_FTRWRITE:
2994 #if defined(HAS_ACCESS) && defined(W_OK)
2995         access_mode = W_OK;
2996 #else
2997         use_access = 0;
2998 #endif
2999         stat_mode = S_IWUSR;
3000         break;
3001
3002     case OP_FTREXEC:
3003 #if defined(HAS_ACCESS) && defined(X_OK)
3004         access_mode = X_OK;
3005 #else
3006         use_access = 0;
3007 #endif
3008         stat_mode = S_IXUSR;
3009         break;
3010
3011     case OP_FTEWRITE:
3012 #ifdef PERL_EFF_ACCESS
3013         access_mode = W_OK;
3014 #endif
3015         stat_mode = S_IWUSR;
3016         /* fall through */
3017
3018     case OP_FTEREAD:
3019 #ifndef PERL_EFF_ACCESS
3020         use_access = 0;
3021 #endif
3022         effective = TRUE;
3023         break;
3024
3025     case OP_FTEEXEC:
3026 #ifdef PERL_EFF_ACCESS
3027         access_mode = X_OK;
3028 #else
3029         use_access = 0;
3030 #endif
3031         stat_mode = S_IXUSR;
3032         effective = TRUE;
3033         break;
3034     }
3035
3036     if (use_access) {
3037 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3038         const char *name = POPpx;
3039         if (effective) {
3040 #  ifdef PERL_EFF_ACCESS
3041             result = PERL_EFF_ACCESS(name, access_mode);
3042 #  else
3043             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3044                 OP_NAME(PL_op));
3045 #  endif
3046         }
3047         else {
3048 #  ifdef HAS_ACCESS
3049             result = access(name, access_mode);
3050 #  else
3051             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3052 #  endif
3053         }
3054         if (result == 0)
3055             RETPUSHYES;
3056         if (result < 0)
3057             RETPUSHUNDEF;
3058         RETPUSHNO;
3059 #endif
3060     }
3061
3062     result = my_stat_flags(0);
3063     SPAGAIN;
3064     if (result < 0)
3065         RETPUSHUNDEF;
3066     if (cando(stat_mode, effective, &PL_statcache))
3067         RETPUSHYES;
3068     RETPUSHNO;
3069 }
3070
3071 PP(pp_ftis)
3072 {
3073     dVAR;
3074     I32 result;
3075     const int op_type = PL_op->op_type;
3076     char opchar = '?';
3077     dSP;
3078
3079     switch (op_type) {
3080     case OP_FTIS:       opchar = 'e'; break;
3081     case OP_FTSIZE:     opchar = 's'; break;
3082     case OP_FTMTIME:    opchar = 'M'; break;
3083     case OP_FTCTIME:    opchar = 'C'; break;
3084     case OP_FTATIME:    opchar = 'A'; break;
3085     }
3086     tryAMAGICftest_MG(opchar);
3087
3088     STACKED_FTEST_CHECK;
3089
3090     result = my_stat_flags(0);
3091     SPAGAIN;
3092     if (result < 0)
3093         RETPUSHUNDEF;
3094     if (op_type == OP_FTIS)
3095         RETPUSHYES;
3096     {
3097         /* You can't dTARGET inside OP_FTIS, because you'll get
3098            "panic: pad_sv po" - the op is not flagged to have a target.  */
3099         dTARGET;
3100         switch (op_type) {
3101         case OP_FTSIZE:
3102 #if Off_t_size > IVSIZE
3103             PUSHn(PL_statcache.st_size);
3104 #else
3105             PUSHi(PL_statcache.st_size);
3106 #endif
3107             break;
3108         case OP_FTMTIME:
3109             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3110             break;
3111         case OP_FTATIME:
3112             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3113             break;
3114         case OP_FTCTIME:
3115             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3116             break;
3117         }
3118     }
3119     RETURN;
3120 }
3121
3122 PP(pp_ftrowned)
3123 {
3124     dVAR;
3125     I32 result;
3126     char opchar = '?';
3127     dSP;
3128
3129     switch (PL_op->op_type) {
3130     case OP_FTROWNED:   opchar = 'O'; break;
3131     case OP_FTEOWNED:   opchar = 'o'; break;
3132     case OP_FTZERO:     opchar = 'z'; break;
3133     case OP_FTSOCK:     opchar = 'S'; break;
3134     case OP_FTCHR:      opchar = 'c'; break;
3135     case OP_FTBLK:      opchar = 'b'; break;
3136     case OP_FTFILE:     opchar = 'f'; break;
3137     case OP_FTDIR:      opchar = 'd'; break;
3138     case OP_FTPIPE:     opchar = 'p'; break;
3139     case OP_FTSUID:     opchar = 'u'; break;
3140     case OP_FTSGID:     opchar = 'g'; break;
3141     case OP_FTSVTX:     opchar = 'k'; break;
3142     }
3143     tryAMAGICftest_MG(opchar);
3144
3145     STACKED_FTEST_CHECK;
3146
3147     /* I believe that all these three are likely to be defined on most every
3148        system these days.  */
3149 #ifndef S_ISUID
3150     if(PL_op->op_type == OP_FTSUID) {
3151         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3152             (void) POPs;
3153         RETPUSHNO;
3154     }
3155 #endif
3156 #ifndef S_ISGID
3157     if(PL_op->op_type == OP_FTSGID) {
3158         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3159             (void) POPs;
3160         RETPUSHNO;
3161     }
3162 #endif
3163 #ifndef S_ISVTX
3164     if(PL_op->op_type == OP_FTSVTX) {
3165         if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3166             (void) POPs;
3167         RETPUSHNO;
3168     }
3169 #endif
3170
3171     result = my_stat_flags(0);
3172     SPAGAIN;
3173     if (result < 0)
3174         RETPUSHUNDEF;
3175     switch (PL_op->op_type) {
3176     case OP_FTROWNED:
3177         if (PL_statcache.st_uid == PL_uid)
3178             RETPUSHYES;
3179         break;
3180     case OP_FTEOWNED:
3181         if (PL_statcache.st_uid == PL_euid)
3182             RETPUSHYES;
3183         break;
3184     case OP_FTZERO:
3185         if (PL_statcache.st_size == 0)
3186             RETPUSHYES;
3187         break;
3188     case OP_FTSOCK:
3189         if (S_ISSOCK(PL_statcache.st_mode))
3190             RETPUSHYES;
3191         break;
3192     case OP_FTCHR:
3193         if (S_ISCHR(PL_statcache.st_mode))
3194             RETPUSHYES;
3195         break;
3196     case OP_FTBLK:
3197         if (S_ISBLK(PL_statcache.st_mode))
3198             RETPUSHYES;
3199         break;
3200     case OP_FTFILE:
3201         if (S_ISREG(PL_statcache.st_mode))
3202             RETPUSHYES;
3203         break;
3204     case OP_FTDIR:
3205         if (S_ISDIR(PL_statcache.st_mode))
3206             RETPUSHYES;
3207         break;
3208     case OP_FTPIPE:
3209         if (S_ISFIFO(PL_statcache.st_mode))
3210             RETPUSHYES;
3211         break;
3212 #ifdef S_ISUID
3213     case OP_FTSUID:
3214         if (PL_statcache.st_mode & S_ISUID)
3215             RETPUSHYES;
3216         break;
3217 #endif
3218 #ifdef S_ISGID
3219     case OP_FTSGID:
3220         if (PL_statcache.st_mode & S_ISGID)
3221             RETPUSHYES;
3222         break;
3223 #endif
3224 #ifdef S_ISVTX
3225     case OP_FTSVTX:
3226         if (PL_statcache.st_mode & S_ISVTX)
3227             RETPUSHYES;
3228         break;
3229 #endif
3230     }
3231     RETPUSHNO;
3232 }
3233
3234 PP(pp_ftlink)
3235 {
3236     dVAR;
3237     dSP;
3238     I32 result;
3239
3240     tryAMAGICftest_MG('l');
3241     result = my_lstat_flags(0);
3242     SPAGAIN;
3243
3244     if (result < 0)
3245         RETPUSHUNDEF;
3246     if (S_ISLNK(PL_statcache.st_mode))
3247         RETPUSHYES;
3248     RETPUSHNO;
3249 }
3250
3251 PP(pp_fttty)
3252 {
3253     dVAR;
3254     dSP;
3255     int fd;
3256     GV *gv;
3257     SV *tmpsv = NULL;
3258     char *name = NULL;
3259     STRLEN namelen;
3260
3261     tryAMAGICftest_MG('t');
3262
3263     STACKED_FTEST_CHECK;
3264
3265     if (PL_op->op_flags & OPf_REF)
3266         gv = cGVOP_gv;
3267     else if (!(gv = MAYBE_DEREF_GV_nomg(TOPs))) {
3268         tmpsv = POPs;
3269         name = SvPV_nomg(tmpsv, namelen);
3270         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3271     }
3272
3273     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3274         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3275     else if (tmpsv && SvOK(tmpsv)) {
3276         if (isDIGIT(*name))
3277             fd = atoi(name);
3278         else 
3279             RETPUSHUNDEF;
3280     }
3281     else
3282         RETPUSHUNDEF;
3283     if (PerlLIO_isatty(fd))
3284         RETPUSHYES;
3285     RETPUSHNO;
3286 }
3287
3288 #if defined(atarist) /* this will work with atariST. Configure will
3289                         make guesses for other systems. */
3290 # define FILE_base(f) ((f)->_base)
3291 # define FILE_ptr(f) ((f)->_ptr)
3292 # define FILE_cnt(f) ((f)->_cnt)
3293 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3294 #endif
3295
3296 PP(pp_fttext)
3297 {
3298     dVAR;
3299     dSP;
3300     I32 i;
3301     I32 len;
3302     I32 odd = 0;
3303     STDCHAR tbuf[512];
3304     register STDCHAR *s;
3305     register IO *io;
3306     register SV *sv;
3307     GV *gv;
3308     PerlIO *fp;
3309
3310     tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
3311
3312     STACKED_FTEST_CHECK;
3313
3314     if (PL_op->op_flags & OPf_REF)
3315         gv = cGVOP_gv;
3316     else gv = MAYBE_DEREF_GV_nomg(TOPs);
3317
3318     if (gv) {
3319         EXTEND(SP, 1);
3320         if (gv == PL_defgv) {
3321             if (PL_statgv)
3322                 io = GvIO(PL_statgv);
3323             else {
3324                 sv = PL_statname;
3325                 goto really_filename;
3326             }
3327         }
3328         else {
3329             PL_statgv = gv;
3330             PL_laststatval = -1;
3331             sv_setpvs(PL_statname, "");
3332             io = GvIO(PL_statgv);
3333         }
3334         if (io && IoIFP(io)) {
3335             if (! PerlIO_has_base(IoIFP(io)))
3336                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3337             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3338             if (PL_laststatval < 0)
3339                 RETPUSHUNDEF;
3340             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3341                 if (PL_op->op_type == OP_FTTEXT)
3342                     RETPUSHNO;
3343                 else
3344                     RETPUSHYES;
3345             }
3346             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3347                 i = PerlIO_getc(IoIFP(io));
3348                 if (i != EOF)
3349                     (void)PerlIO_ungetc(IoIFP(io),i);
3350             }
3351             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3352                 RETPUSHYES;
3353             len = PerlIO_get_bufsiz(IoIFP(io));
3354             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3355             /* sfio can have large buffers - limit to 512 */
3356             if (len > 512)
3357                 len = 512;
3358         }
3359         else {
3360             report_evil_fh(cGVOP_gv);
3361             SETERRNO(EBADF,RMS_IFI);
3362             RETPUSHUNDEF;
3363         }
3364     }
3365     else {
3366         sv = POPs;
3367       really_filename:
3368         PL_statgv = NULL;
3369         PL_laststype = OP_STAT;
3370         sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3371         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3372             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3373                                                '\n'))
3374                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3375             RETPUSHUNDEF;
3376         }
3377         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3378         if (PL_laststatval < 0) {
3379             (void)PerlIO_close(fp);
3380             RETPUSHUNDEF;
3381         }
3382         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3383         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3384         (void)PerlIO_close(fp);
3385         if (len <= 0) {
3386             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3387                 RETPUSHNO;              /* special case NFS directories */
3388             RETPUSHYES;         /* null file is anything */
3389         }
3390         s = tbuf;
3391     }
3392
3393     /* now scan s to look for textiness */
3394     /*   XXX ASCII dependent code */
3395
3396 #if defined(DOSISH) || defined(USEMYBINMODE)
3397     /* ignore trailing ^Z on short files */
3398     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3399         --len;
3400 #endif
3401
3402     for (i = 0; i < len; i++, s++) {
3403         if (!*s) {                      /* null never allowed in text */
3404             odd += len;
3405             break;
3406         }
3407 #ifdef EBCDIC
3408         else if (!(isPRINT(*s) || isSPACE(*s)))
3409             odd++;
3410 #else
3411         else if (*s & 128) {
3412 #ifdef USE_LOCALE
3413             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3414                 continue;
3415 #endif
3416             /* utf8 characters don't count as odd */
3417             if (UTF8_IS_START(*s)) {
3418                 int ulen = UTF8SKIP(s);
3419                 if (ulen < len - i) {
3420                     int j;
3421                     for (j = 1; j < ulen; j++) {
3422                         if (!UTF8_IS_CONTINUATION(s[j]))
3423                             goto not_utf8;
3424                     }
3425                     --ulen;     /* loop does extra increment */
3426                     s += ulen;
3427                     i += ulen;
3428                     continue;
3429                 }
3430             }
3431           not_utf8:
3432             odd++;
3433         }
3434         else if (*s < 32 &&
3435           *s != '\n' && *s != '\r' && *s != '\b' &&
3436           *s != '\t' && *s != '\f' && *s != 27)
3437             odd++;
3438 #endif
3439     }
3440
3441     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3442         RETPUSHNO;
3443     else
3444         RETPUSHYES;
3445 }
3446
3447 /* File calls. */
3448
3449 PP(pp_chdir)
3450 {
3451     dVAR; dSP; dTARGET;
3452     const char *tmps = NULL;
3453     GV *gv = NULL;
3454
3455     if( MAXARG == 1 ) {
3456         SV * const sv = POPs;
3457         if (PL_op->op_flags & OPf_SPECIAL) {
3458             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3459         }
3460         else if (!(gv = MAYBE_DEREF_GV(sv)))
3461                 tmps = SvPV_nomg_const_nolen(sv);
3462     }
3463
3464     if( !gv && (!tmps || !*tmps) ) {
3465         HV * const table = GvHVn(PL_envgv);
3466         SV **svp;
3467
3468         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3469              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3470 #ifdef VMS
3471              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3472 #endif
3473            )
3474         {
3475             if( MAXARG == 1 )
3476                 deprecate("chdir('') or chdir(undef) as chdir()");
3477             tmps = SvPV_nolen_const(*svp);
3478         }
3479         else {
3480             PUSHi(0);
3481             TAINT_PROPER("chdir");
3482             RETURN;
3483         }
3484     }
3485
3486     TAINT_PROPER("chdir");
3487     if (gv) {
3488 #ifdef HAS_FCHDIR
3489         IO* const io = GvIO(gv);
3490         if (io) {
3491             if (IoDIRP(io)) {
3492                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3493             } else if (IoIFP(io)) {
3494                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3495             }
3496             else {
3497                 report_evil_fh(gv);
3498                 SETERRNO(EBADF, RMS_IFI);
3499                 PUSHi(0);
3500             }
3501         }
3502         else {
3503             report_evil_fh(gv);
3504             SETERRNO(EBADF,RMS_IFI);
3505             PUSHi(0);
3506         }
3507 #else
3508         DIE(aTHX_ PL_no_func, "fchdir");
3509 #endif
3510     }
3511     else 
3512         PUSHi( PerlDir_chdir(tmps) >= 0 );
3513 #ifdef VMS
3514     /* Clear the DEFAULT element of ENV so we'll get the new value
3515      * in the future. */
3516     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3517 #endif
3518     RETURN;
3519 }
3520
3521 PP(pp_chown)
3522 {
3523     dVAR; dSP; dMARK; dTARGET;
3524     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3525
3526     SP = MARK;
3527     XPUSHi(value);
3528     RETURN;
3529 }
3530
3531 PP(pp_chroot)
3532 {
3533 #ifdef HAS_CHROOT
3534     dVAR; dSP; dTARGET;
3535     char * const tmps = POPpx;
3536     TAINT_PROPER("chroot");
3537     PUSHi( chroot(tmps) >= 0 );
3538     RETURN;
3539 #else
3540     DIE(aTHX_ PL_no_func, "chroot");
3541 #endif
3542 }
3543
3544 PP(pp_rename)
3545 {
3546     dVAR; dSP; dTARGET;
3547     int anum;
3548     const char * const tmps2 = POPpconstx;
3549     const char * const tmps = SvPV_nolen_const(TOPs);
3550     TAINT_PROPER("rename");
3551 #ifdef HAS_RENAME
3552     anum = PerlLIO_rename(tmps, tmps2);
3553 #else
3554     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3555         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3556             anum = 1;
3557         else {
3558             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3559                 (void)UNLINK(tmps2);
3560             if (!(anum = link(tmps, tmps2)))
3561                 anum = UNLINK(tmps);
3562         }
3563     }
3564 #endif
3565     SETi( anum >= 0 );
3566     RETURN;
3567 }
3568
3569 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3570 PP(pp_link)
3571 {
3572     dVAR; dSP; dTARGET;
3573     const int op_type = PL_op->op_type;
3574     int result;
3575
3576 #  ifndef HAS_LINK
3577     if (op_type == OP_LINK)
3578         DIE(aTHX_ PL_no_func, "link");
3579 #  endif
3580 #  ifndef HAS_SYMLINK
3581     if (op_type == OP_SYMLINK)
3582         DIE(aTHX_ PL_no_func, "symlink");
3583 #  endif
3584
3585     {
3586         const char * const tmps2 = POPpconstx;
3587         const char * const tmps = SvPV_nolen_const(TOPs);
3588         TAINT_PROPER(PL_op_desc[op_type]);
3589         result =
3590 #  if defined(HAS_LINK)
3591 #    if defined(HAS_SYMLINK)
3592             /* Both present - need to choose which.  */
3593             (op_type == OP_LINK) ?
3594             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3595 #    else
3596     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3597         PerlLIO_link(tmps, tmps2);
3598 #    endif
3599 #  else
3600 #    if defined(HAS_SYMLINK)
3601     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3602         symlink(tmps, tmps2);
3603 #    endif
3604 #  endif
3605     }
3606
3607     SETi( result >= 0 );
3608     RETURN;
3609 }
3610 #else
3611 PP(pp_link)
3612 {
3613     /* Have neither.  */
3614     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3615 }
3616 #endif
3617
3618 PP(pp_readlink)
3619 {
3620     dVAR;
3621     dSP;
3622 #ifdef HAS_SYMLINK
3623     dTARGET;
3624     const char *tmps;
3625     char buf[MAXPATHLEN];
3626     int len;
3627
3628 #ifndef INCOMPLETE_TAINTS
3629     TAINT;
3630 #endif
3631     tmps = POPpconstx;
3632     len = readlink(tmps, buf, sizeof(buf) - 1);
3633     if (len < 0)
3634         RETPUSHUNDEF;
3635     PUSHp(buf, len);
3636     RETURN;
3637 #else
3638     EXTEND(SP, 1);
3639     RETSETUNDEF;                /* just pretend it's a normal file */
3640 #endif
3641 }
3642
3643 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3644 STATIC int
3645 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3646 {
3647     char * const save_filename = filename;
3648     char *cmdline;
3649     char *s;
3650     PerlIO *myfp;
3651     int anum = 1;
3652     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3653
3654     PERL_ARGS_ASSERT_DOONELINER;
3655
3656     Newx(cmdline, size, char);
3657     my_strlcpy(cmdline, cmd, size);
3658     my_strlcat(cmdline, " ", size);
3659     for (s = cmdline + strlen(cmdline); *filename; ) {
3660         *s++ = '\\';
3661         *s++ = *filename++;
3662     }
3663     if (s - cmdline < size)
3664         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3665     myfp = PerlProc_popen(cmdline, "r");
3666     Safefree(cmdline);
3667
3668     if (myfp) {
3669         SV * const tmpsv = sv_newmortal();
3670         /* Need to save/restore 'PL_rs' ?? */
3671         s = sv_gets(tmpsv, myfp, 0);
3672         (void)PerlProc_pclose(myfp);
3673         if (s != NULL) {
3674             int e;
3675             for (e = 1;
3676 #ifdef HAS_SYS_ERRLIST
3677                  e <= sys_nerr
3678 #endif
3679                  ; e++)
3680             {
3681                 /* you don't see this */
3682                 const char * const errmsg =
3683 #ifdef HAS_SYS_ERRLIST
3684                     sys_errlist[e]
3685 #else
3686                     strerror(e)
3687 #endif
3688                     ;
3689                 if (!errmsg)
3690                     break;
3691                 if (instr(s, errmsg)) {
3692                     SETERRNO(e,0);
3693                     return 0;
3694                 }
3695             }
3696             SETERRNO(0,0);
3697 #ifndef EACCES
3698 #define EACCES EPERM
3699 #endif
3700             if (instr(s, "cannot make"))
3701                 SETERRNO(EEXIST,RMS_FEX);
3702             else if (instr(s, "existing file"))
3703                 SETERRNO(EEXIST,RMS_FEX);
3704             else if (instr(s, "ile exists"))
3705                 SETERRNO(EEXIST,RMS_FEX);
3706             else if (instr(s, "non-exist"))
3707                 SETERRNO(ENOENT,RMS_FNF);
3708             else if (instr(s, "does not exist"))
3709                 SETERRNO(ENOENT,RMS_FNF);
3710             else if (instr(s, "not empty"))
3711                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3712             else if (instr(s, "cannot access"))
3713                 SETERRNO(EACCES,RMS_PRV);
3714             else
3715                 SETERRNO(EPERM,RMS_PRV);
3716             return 0;
3717         }
3718         else {  /* some mkdirs return no failure indication */
3719             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3720             if (PL_op->op_type == OP_RMDIR)
3721                 anum = !anum;
3722             if (anum)
3723                 SETERRNO(0,0);
3724             else
3725                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3726         }
3727         return anum;
3728     }
3729     else
3730         return 0;
3731 }
3732 #endif
3733
3734 /* This macro removes trailing slashes from a directory name.
3735  * Different operating and file systems take differently to
3736  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3737  * any number of trailing slashes should be allowed.
3738  * Thusly we snip them away so that even non-conforming
3739  * systems are happy.
3740  * We should probably do this "filtering" for all
3741  * the functions that expect (potentially) directory names:
3742  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3743  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3744
3745 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3746     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3747         do { \
3748             (len)--; \
3749         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3750         (tmps) = savepvn((tmps), (len)); \
3751         (copy) = TRUE; \
3752     }
3753
3754 PP(pp_mkdir)
3755 {
3756     dVAR; dSP; dTARGET;
3757     STRLEN len;
3758     const char *tmps;
3759     bool copy = FALSE;
3760     const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
3761
3762     TRIMSLASHES(tmps,len,copy);
3763
3764     TAINT_PROPER("mkdir");
3765 #ifdef HAS_MKDIR
3766     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3767 #else
3768     {
3769     int oldumask;
3770     SETi( dooneliner("mkdir", tmps) );
3771     oldumask = PerlLIO_umask(0);
3772     PerlLIO_umask(oldumask);
3773     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3774     }
3775 #endif
3776     if (copy)
3777         Safefree(tmps);
3778     RETURN;
3779 }
3780
3781 PP(pp_rmdir)
3782 {
3783     dVAR; dSP; dTARGET;
3784     STRLEN len;
3785     const char *tmps;
3786     bool copy = FALSE;
3787
3788     TRIMSLASHES(tmps,len,copy);
3789     TAINT_PROPER("rmdir");
3790 #ifdef HAS_RMDIR
3791     SETi( PerlDir_rmdir(tmps) >= 0 );
3792 #else
3793     SETi( dooneliner("rmdir", tmps) );
3794 #endif
3795     if (copy)
3796         Safefree(tmps);
3797     RETURN;
3798 }
3799
3800 /* Directory calls. */
3801
3802 PP(pp_open_dir)
3803 {
3804 #if defined(Direntry_t) && defined(HAS_READDIR)
3805     dVAR; dSP;
3806     const char * const dirname = POPpconstx;
3807     GV * const gv = MUTABLE_GV(POPs);
3808     register IO * const io = GvIOn(gv);
3809
3810     if (!io)
3811         goto nope;
3812
3813     if ((IoIFP(io) || IoOFP(io)))
3814         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3815                          "Opening filehandle %s also as a directory",
3816                          GvENAME(gv));
3817     if (IoDIRP(io))
3818         PerlDir_close(IoDIRP(io));
3819     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3820         goto nope;
3821
3822     RETPUSHYES;
3823 nope:
3824     if (!errno)
3825         SETERRNO(EBADF,RMS_DIR);
3826     RETPUSHUNDEF;
3827 #else
3828     DIE(aTHX_ PL_no_dir_func, "opendir");
3829 #endif
3830 }
3831
3832 PP(pp_readdir)
3833 {
3834 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3835     DIE(aTHX_ PL_no_dir_func, "readdir");
3836 #else
3837 #if !defined(I_DIRENT) && !defined(VMS)
3838     Direntry_t *readdir (DIR *);
3839 #endif
3840     dVAR;
3841     dSP;
3842
3843     SV *sv;
3844     const I32 gimme = GIMME;
3845     GV * const gv = MUTABLE_GV(POPs);
3846     register const Direntry_t *dp;
3847     register IO * const io = GvIOn(gv);
3848
3849     if (!io || !IoDIRP(io)) {
3850         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3851                        "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3852         goto nope;
3853     }
3854
3855     do {
3856         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3857         if (!dp)
3858             break;
3859 #ifdef DIRNAMLEN
3860         sv = newSVpvn(dp->d_name, dp->d_namlen);
3861 #else
3862         sv = newSVpv(dp->d_name, 0);
3863 #endif
3864 #ifndef INCOMPLETE_TAINTS
3865         if (!(IoFLAGS(io) & IOf_UNTAINT))
3866             SvTAINTED_on(sv);
3867 #endif
3868         mXPUSHs(sv);
3869     } while (gimme == G_ARRAY);
3870
3871     if (!dp && gimme != G_ARRAY)
3872         goto nope;
3873
3874     RETURN;
3875
3876 nope:
3877     if (!errno)
3878         SETERRNO(EBADF,RMS_ISI);
3879     if (GIMME == G_ARRAY)
3880         RETURN;
3881     else
3882         RETPUSHUNDEF;
3883 #endif
3884 }
3885
3886 PP(pp_telldir)
3887 {
3888 #if defined(HAS_TELLDIR) || defined(telldir)
3889     dVAR; dSP; dTARGET;
3890  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3891  /* XXX netbsd still seemed to.
3892     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3893     --JHI 1999-Feb-02 */
3894 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3895     long telldir (DIR *);
3896 # endif
3897     GV * const gv = MUTABLE_GV(POPs);
3898     register IO * const io = GvIOn(gv);
3899
3900     if (!io || !IoDIRP(io)) {
3901         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3902                        "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3903         goto nope;
3904     }
3905
3906     PUSHi( PerlDir_tell(IoDIRP(io)) );
3907     RETURN;
3908 nope:
3909     if (!errno)
3910         SETERRNO(EBADF,RMS_ISI);
3911     RETPUSHUNDEF;
3912 #else
3913     DIE(aTHX_ PL_no_dir_func, "telldir");
3914 #endif
3915 }
3916
3917 PP(pp_seekdir)
3918 {
3919 #if defined(HAS_SEEKDIR) || defined(seekdir)
3920     dVAR; dSP;
3921     const long along = POPl;
3922     GV * const gv = MUTABLE_GV(POPs);
3923     register IO * const io = GvIOn(gv);
3924
3925     if (!io || !IoDIRP(io)) {
3926         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3927                        "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3928         goto nope;
3929     }
3930     (void)PerlDir_seek(IoDIRP(io), along);
3931
3932     RETPUSHYES;
3933 nope:
3934     if (!errno)
3935         SETERRNO(EBADF,RMS_ISI);
3936     RETPUSHUNDEF;
3937 #else
3938     DIE(aTHX_ PL_no_dir_func, "seekdir");
3939 #endif
3940 }
3941
3942 PP(pp_rewinddir)
3943 {
3944 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3945     dVAR; dSP;
3946     GV * const gv = MUTABLE_GV(POPs);
3947     register IO * const io = GvIOn(gv);
3948
3949     if (!io || !IoDIRP(io)) {
3950         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3951                        "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3952         goto nope;
3953     }
3954     (void)PerlDir_rewind(IoDIRP(io));
3955     RETPUSHYES;
3956 nope:
3957     if (!errno)
3958         SETERRNO(EBADF,RMS_ISI);
3959     RETPUSHUNDEF;
3960 #else
3961     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3962 #endif
3963 }
3964
3965 PP(pp_closedir)
3966 {
3967 #if defined(Direntry_t) && defined(HAS_READDIR)
3968     dVAR; dSP;
3969     GV * const gv = MUTABLE_GV(POPs);
3970     register IO * const io = GvIOn(gv);
3971
3972     if (!io || !IoDIRP(io)) {
3973         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3974                        "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3975         goto nope;
3976     }
3977 #ifdef VOID_CLOSEDIR
3978     PerlDir_close(IoDIRP(io));
3979 #else
3980     if (PerlDir_close(IoDIRP(io)) < 0) {
3981         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3982         goto nope;
3983     }
3984 #endif
3985     IoDIRP(io) = 0;
3986
3987     RETPUSHYES;
3988 nope:
3989     if (!errno)
3990         SETERRNO(EBADF,RMS_IFI);
3991     RETPUSHUNDEF;
3992 #else
3993     DIE(aTHX_ PL_no_dir_func, "closedir");
3994 #endif
3995 }
3996
3997 /* Process control. */
3998
3999 PP(pp_fork)
4000 {
4001 #ifdef HAS_FORK
4002     dVAR; dSP; dTARGET;
4003     Pid_t childpid;
4004
4005     EXTEND(SP, 1);
4006     PERL_FLUSHALL_FOR_CHILD;
4007     childpid = PerlProc_fork();
4008     if (childpid < 0)
4009         RETSETUNDEF;
4010     if (!childpid) {
4011 #ifdef THREADS_HAVE_PIDS
4012         PL_ppid = (IV)getppid();
4013 #endif
4014 #ifdef PERL_USES_PL_PIDSTATUS
4015         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4016 #endif
4017     }
4018     PUSHi(childpid);
4019     RETURN;
4020 #else
4021 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4022     dSP; dTARGET;
4023     Pid_t childpid;
4024
4025     EXTEND(SP, 1);
4026     PERL_FLUSHALL_FOR_CHILD;
4027     childpid = PerlProc_fork();
4028     if (childpid == -1)
4029         RETSETUNDEF;
4030     PUSHi(childpid);
4031     RETURN;
4032 #  else
4033     DIE(aTHX_ PL_no_func, "fork");
4034 #  endif
4035 #endif
4036 }
4037
4038 PP(pp_wait)
4039 {
4040 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4041     dVAR; dSP; dTARGET;
4042     Pid_t childpid;
4043     int argflags;
4044
4045     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4046         childpid = wait4pid(-1, &argflags, 0);
4047     else {
4048         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4049                errno == EINTR) {
4050           PERL_ASYNC_CHECK();
4051         }
4052     }
4053 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4054     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4055     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4056 #  else
4057     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4058 #  endif
4059     XPUSHi(childpid);
4060     RETURN;
4061 #else
4062     DIE(aTHX_ PL_no_func, "wait");
4063 #endif
4064 }
4065
4066 PP(pp_waitpid)
4067 {
4068 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4069     dVAR; dSP; dTARGET;
4070     const int optype = POPi;
4071     const Pid_t pid = TOPi;
4072     Pid_t result;
4073     int argflags;
4074
4075     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4076         result = wait4pid(pid, &argflags, optype);
4077     else {
4078         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4079                errno == EINTR) {
4080           PERL_ASYNC_CHECK();
4081         }
4082     }
4083 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4084     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4085     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4086 #  else
4087     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4088 #  endif
4089     SETi(result);
4090     RETURN;
4091 #else
4092     DIE(aTHX_ PL_no_func, "waitpid");
4093 #endif
4094 }
4095
4096 PP(pp_system)
4097 {
4098     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4099 #if defined(__LIBCATAMOUNT__)
4100     PL_statusvalue = -1;
4101     SP = ORIGMARK;
4102     XPUSHi(-1);
4103 #else
4104     I32 value;
4105     int result;
4106
4107     if (PL_tainting) {
4108         TAINT_ENV();
4109         while (++MARK <= SP) {
4110             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4111             if (PL_tainted)
4112                 break;
4113         }
4114         MARK = ORIGMARK;
4115         TAINT_PROPER("system");
4116     }
4117     PERL_FLUSHALL_FOR_CHILD;
4118 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4119     {
4120         Pid_t childpid;
4121         int pp[2];
4122         I32 did_pipes = 0;
4123
4124         if (PerlProc_pipe(pp) >= 0)
4125             did_pipes = 1;
4126         while ((childpid = PerlProc_fork()) == -1) {
4127             if (errno != EAGAIN) {
4128                 value = -1;
4129                 SP = ORIGMARK;
4130                 XPUSHi(value);
4131                 if (did_pipes) {
4132                     PerlLIO_close(pp[0]);
4133                     PerlLIO_close(pp[1]);
4134                 }
4135                 RETURN;
4136             }
4137             sleep(5);
4138         }
4139         if (childpid > 0) {
4140             Sigsave_t ihand,qhand; /* place to save signals during system() */
4141             int status;
4142
4143             if (did_pipes)
4144                 PerlLIO_close(pp[1]);
4145 #ifndef PERL_MICRO
4146             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4147             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4148 #endif
4149             do {
4150                 result = wait4pid(childpid, &status, 0);
4151             } while (result == -1 && errno == EINTR);
4152 #ifndef PERL_MICRO
4153             (void)rsignal_restore(SIGINT, &ihand);
4154             (void)rsignal_restore(SIGQUIT, &qhand);
4155 #endif
4156             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4157             do_execfree();      /* free any memory child malloced on fork */
4158             SP = ORIGMARK;
4159             if (did_pipes) {
4160                 int errkid;
4161                 unsigned n = 0;
4162                 SSize_t n1;
4163
4164                 while (n < sizeof(int)) {
4165                     n1 = PerlLIO_read(pp[0],
4166                                       (void*)(((char*)&errkid)+n),
4167                                       (sizeof(int)) - n);
4168                     if (n1 <= 0)
4169                         break;
4170                     n += n1;
4171                 }
4172                 PerlLIO_close(pp[0]);
4173                 if (n) {                        /* Error */
4174                     if (n != sizeof(int))
4175                         DIE(aTHX_ "panic: kid popen errno read");
4176                     errno = errkid;             /* Propagate errno from kid */
4177                     STATUS_NATIVE_CHILD_SET(-1);
4178                 }
4179             }
4180             XPUSHi(STATUS_CURRENT);
4181             RETURN;
4182         }
4183         if (did_pipes) {
4184             PerlLIO_close(pp[0]);
4185 #if defined(HAS_FCNTL) && defined(F_SETFD)
4186             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4187 #endif
4188         }
4189         if (PL_op->op_flags & OPf_STACKED) {
4190             SV * const really = *++MARK;
4191             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4192         }
4193         else if (SP - MARK != 1)
4194             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4195         else {
4196             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4197         }
4198         PerlProc__exit(-1);
4199     }
4200 #else /* ! FORK or VMS or OS/2 */
4201     PL_statusvalue = 0;
4202     result = 0;
4203     if (PL_op->op_flags & OPf_STACKED) {
4204         SV * const really = *++MARK;
4205 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4206         value = (I32)do_aspawn(really, MARK, SP);
4207 #  else
4208         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4209 #  endif
4210     }
4211     else if (SP - MARK != 1) {
4212 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS)
4213         value = (I32)do_aspawn(NULL, MARK, SP);
4214 #  else
4215         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4216 #  endif
4217     }
4218     else {
4219         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4220     }
4221     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4222         result = 1;
4223     STATUS_NATIVE_CHILD_SET(value);
4224     do_execfree();
4225     SP = ORIGMARK;
4226     XPUSHi(result ? value : STATUS_CURRENT);
4227 #endif /* !FORK or VMS or OS/2 */
4228 #endif
4229     RETURN;
4230 }
4231
4232 PP(pp_exec)
4233 {
4234     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4235     I32 value;
4236
4237     if (PL_tainting) {
4238         TAINT_ENV();
4239         while (++MARK <= SP) {
4240             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4241             if (PL_tainted)
4242                 break;
4243         }
4244         MARK = ORIGMARK;
4245         TAINT_PROPER("exec");
4246     }
4247     PERL_FLUSHALL_FOR_CHILD;
4248     if (PL_op->op_flags & OPf_STACKED) {
4249         SV * const really = *++MARK;
4250         value = (I32)do_aexec(really, MARK, SP);
4251     }
4252     else if (SP - MARK != 1)
4253 #ifdef VMS
4254         value = (I32)vms_do_aexec(NULL, MARK, SP);
4255 #else
4256 #  ifdef __OPEN_VM
4257         {
4258            (void ) do_aspawn(NULL, MARK, SP);
4259            value = 0;
4260         }
4261 #  else
4262         value = (I32)do_aexec(NULL, MARK, SP);
4263 #  endif
4264 #endif
4265     else {
4266 #ifdef VMS
4267         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4268 #else
4269 #  ifdef __OPEN_VM
4270         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4271         value = 0;
4272 #  else
4273         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4274 #  endif
4275 #endif
4276     }
4277
4278     SP = ORIGMARK;
4279     XPUSHi(value);
4280     RETURN;
4281 }
4282
4283 PP(pp_getppid)
4284 {
4285 #ifdef HAS_GETPPID
4286     dVAR; dSP; dTARGET;
4287 #   ifdef THREADS_HAVE_PIDS
4288     if (PL_ppid != 1 && getppid() == 1)
4289         /* maybe the parent process has died. Refresh ppid cache */
4290         PL_ppid = 1;
4291     XPUSHi( PL_ppid );
4292 #   else
4293     XPUSHi( getppid() );
4294 #   endif
4295     RETURN;
4296 #else
4297     DIE(aTHX_ PL_no_func, "getppid");
4298 #endif
4299 }
4300
4301 PP(pp_getpgrp)
4302 {
4303 #ifdef HAS_GETPGRP
4304     dVAR; dSP; dTARGET;
4305     Pid_t pgrp;
4306     const Pid_t pid =
4307         (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0);
4308
4309 #ifdef BSD_GETPGRP
4310     pgrp = (I32)BSD_GETPGRP(pid);
4311 #else
4312     if (pid != 0 && pid != PerlProc_getpid())
4313         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4314     pgrp = getpgrp();
4315 #endif
4316     XPUSHi(pgrp);
4317     RETURN;
4318 #else
4319     DIE(aTHX_ PL_no_func, "getpgrp()");
4320 #endif
4321 }
4322
4323 PP(pp_setpgrp)
4324 {
4325 #ifdef HAS_SETPGRP
4326     dVAR; dSP; dTARGET;
4327     Pid_t pgrp;
4328     Pid_t pid;
4329     pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0;
4330     if (MAXARG > 0) pid = TOPs && TOPi;
4331     else {
4332         pid = 0;
4333         XPUSHi(-1);
4334     }
4335
4336     TAINT_PROPER("setpgrp");
4337 #ifdef BSD_SETPGRP
4338     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
4339 #else
4340     if ((pgrp != 0 && pgrp != PerlProc_getpid())
4341         || (pid != 0 && pid != PerlProc_getpid()))
4342     {
4343         DIE(aTHX_ "setpgrp can't take arguments");
4344     }
4345     SETi( setpgrp() >= 0 );
4346 #endif /* USE_BSDPGRP */
4347     RETURN;
4348 #else
4349     DIE(aTHX_ PL_no_func, "setpgrp()");
4350 #endif
4351 }
4352
4353 #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2))
4354 #  define PRIORITY_WHICH_T(which) (__priority_which_t)which
4355 #else
4356 #  define PRIORITY_WHICH_T(which) which
4357 #endif
4358
4359 PP(pp_getpriority)
4360 {
4361 #ifdef HAS_GETPRIORITY
4362     dVAR; dSP; dTARGET;
4363     const int who = POPi;
4364     const int which = TOPi;
4365     SETi( getpriority(PRIORITY_WHICH_T(which), who) );
4366     RETURN;
4367 #else
4368     DIE(aTHX_ PL_no_func, "getpriority()");
4369 #endif
4370 }
4371
4372 PP(pp_setpriority)
4373 {
4374 #ifdef HAS_SETPRIORITY
4375     dVAR; dSP; dTARGET;
4376     const int niceval = POPi;
4377     const int who = POPi;
4378     const int which = TOPi;
4379     TAINT_PROPER("setpriority");
4380     SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 );
4381     RETURN;
4382 #else
4383     DIE(aTHX_ PL_no_func, "setpriority()");
4384 #endif
4385 }
4386
4387 #undef PRIORITY_WHICH_T
4388
4389 /* Time calls. */
4390
4391 PP(pp_time)
4392 {
4393     dVAR; dSP; dTARGET;
4394 #ifdef BIG_TIME
4395     XPUSHn( time(NULL) );
4396 #else
4397     XPUSHi( time(NULL) );
4398 #endif
4399     RETURN;
4400 }
4401
4402 PP(pp_tms)
4403 {
4404 #ifdef HAS_TIMES
4405     dVAR;
4406     dSP;
4407     EXTEND(SP, 4);
4408 #ifndef VMS
4409     (void)PerlProc_times(&PL_timesbuf);
4410 #else
4411     (void)PerlProc_times((tbuffer_t *)&PL_timesbuf);  /* time.h uses different name for */
4412                                                    /* struct tms, though same data   */
4413                                                    /* is returned.                   */
4414 #endif
4415
4416     mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick);
4417     if (GIMME == G_ARRAY) {
4418         mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick);
4419         mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick);
4420         mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick);
4421     }
4422     RETURN;
4423 #else
4424 #   ifdef PERL_MICRO
4425     dSP;
4426     mPUSHn(0.0);
4427     EXTEND(SP, 4);
4428     if (GIMME == G_ARRAY) {
4429          mPUSHn(0.0);
4430          mPUSHn(0.0);
4431          mPUSHn(0.0);
4432     }
4433     RETURN;
4434 #   else
4435     DIE(aTHX_ "times not implemented");
4436 #   endif
4437 #endif /* HAS_TIMES */
4438 }
4439
4440 /* The 32 bit int year limits the times we can represent to these
4441    boundaries with a few days wiggle room to account for time zone
4442    offsets
4443 */
4444 /* Sat Jan  3 00:00:00 -2147481748 */
4445 #define TIME_LOWER_BOUND -67768100567755200.0
4446 /* Sun Dec 29 12:00:00  2147483647 */
4447 #define TIME_UPPER_BOUND  67767976233316800.0
4448
4449 PP(pp_gmtime)
4450 {
4451     dVAR;
4452     dSP;
4453     Time64_T when;
4454     struct TM tmbuf;
4455     struct TM *err;
4456     const char *opname = PL_op->op_type == OP_LOCALTIME ? "localtime" : "gmtime";
4457     static const char * const dayname[] =
4458         {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4459     static const char * const monname[] =
4460         {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4461          "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4462
4463     if (MAXARG < 1 || (!TOPs && ((void)POPs, 1))) {
4464         time_t now;
4465         (void)time(&now);
4466         when = (Time64_T)now;
4467     }
4468     else {
4469         NV input = Perl_floor(POPn);
4470         when = (Time64_T)input;
4471         if (when != input) {
4472             Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4473                            "%s(%.0" NVff ") too large", opname, input);
4474         }
4475     }
4476
4477     if ( TIME_LOWER_BOUND > when ) {
4478         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4479                        "%s(%.0" NVff ") too small", opname, when);
4480         err = NULL;
4481     }
4482     else if( when > TIME_UPPER_BOUND ) {
4483         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4484                        "%s(%.0" NVff ") too large", opname, when);
4485         err = NULL;
4486     }
4487     else {
4488         if (PL_op->op_type == OP_LOCALTIME)
4489             err = S_localtime64_r(&when, &tmbuf);
4490         else
4491             err = S_gmtime64_r(&when, &tmbuf);
4492     }
4493
4494     if (err == NULL) {
4495         /* XXX %lld broken for quads */
4496         Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
4497                        "%s(%.0" NVff ") failed", opname, when);
4498     }
4499
4500     if (GIMME != G_ARRAY) {     /* scalar context */
4501         SV *tsv;
4502         /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */
4503         double year = (double)tmbuf.tm_year + 1900;
4504
4505         EXTEND(SP, 1);
4506         EXTEND_MORTAL(1);
4507         if (err == NULL)
4508             RETPUSHUNDEF;
4509
4510         tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f",
4511                             dayname[tmbuf.tm_wday],
4512                             monname[tmbuf.tm_mon],
4513                             tmbuf.tm_mday,
4514                             tmbuf.tm_hour,
4515                             tmbuf.tm_min,
4516                             tmbuf.tm_sec,
4517                             year);
4518         mPUSHs(tsv);
4519     }
4520     else {                      /* list context */
4521         if ( err == NULL )
4522             RETURN;
4523
4524         EXTEND(SP, 9);
4525         EXTEND_MORTAL(9);
4526         mPUSHi(tmbuf.tm_sec);
4527         mPUSHi(tmbuf.tm_min);
4528         mPUSHi(tmbuf.tm_hour);
4529         mPUSHi(tmbuf.tm_mday);
4530         mPUSHi(tmbuf.tm_mon);
4531         mPUSHn(tmbuf.tm_year);
4532         mPUSHi(tmbuf.tm_wday);
4533         mPUSHi(tmbuf.tm_yday);
4534         mPUSHi(tmbuf.tm_isdst);
4535     }
4536     RETURN;
4537 }
4538
4539 PP(pp_alarm)
4540 {
4541 #ifdef HAS_ALARM
4542     dVAR; dSP; dTARGET;
4543     int anum;
4544     anum = POPi;
4545     anum = alarm((unsigned int)anum);
4546     if (anum < 0)
4547         RETPUSHUNDEF;
4548     PUSHi(anum);
4549     RETURN;
4550 #else
4551     DIE(aTHX_ PL_no_func, "alarm");
4552 #endif
4553 }
4554
4555 PP(pp_sleep)
4556 {
4557     dVAR; dSP; dTARGET;
4558     I32 duration;
4559     Time_t lasttime;
4560     Time_t when;
4561
4562     (void)time(&lasttime);
4563     if (MAXARG < 1 || (!TOPs && !POPs))
4564         PerlProc_pause();
4565     else {
4566         duration = POPi;
4567         PerlProc_sleep((unsigned int)duration);
4568     }
4569     (void)time(&when);
4570     XPUSHi(when - lasttime);
4571     RETURN;
4572 }
4573
4574 /* Shared memory. */
4575 /* Merged with some message passing. */
4576
4577 PP(pp_shmwrite)
4578 {
4579 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4580     dVAR; dSP; dMARK; dTARGET;
4581     const int op_type = PL_op->op_type;
4582     I32 value;
4583
4584     switch (op_type) {
4585     case OP_MSGSND:
4586         value = (I32)(do_msgsnd(MARK, SP) >= 0);
4587         break;
4588     case OP_MSGRCV:
4589         value = (I32)(do_msgrcv(MARK, SP) >= 0);
4590         break;
4591     case OP_SEMOP:
4592         value = (I32)(do_semop(MARK, SP) >= 0);
4593         break;
4594     default:
4595         value = (I32)(do_shmio(op_type, MARK, SP) >= 0);
4596         break;
4597     }
4598
4599     SP = MARK;
4600     PUSHi(value);
4601     RETURN;
4602 #else
4603     return Perl_pp_semget(aTHX);
4604 #endif
4605 }
4606
4607 /* Semaphores. */
4608
4609 PP(pp_semget)
4610 {
4611 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4612     dVAR; dSP; dMARK; dTARGET;
4613     const int anum = do_ipcget(PL_op->op_type, MARK, SP);
4614     SP = MARK;
4615     if (anum == -1)
4616         RETPUSHUNDEF;
4617     PUSHi(anum);
4618     RETURN;
4619 #else
4620     DIE(aTHX_ "System V IPC is not implemented on this machine");
4621 #endif
4622 }
4623
4624 PP(pp_semctl)
4625 {
4626 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4627     dVAR; dSP; dMARK; dTARGET;
4628     const int anum = do_ipcctl(PL_op->op_type, MARK, SP);
4629     SP = MARK;
4630     if (anum == -1)
4631         RETSETUNDEF;
4632     if (anum != 0) {
4633         PUSHi(anum);
4634     }
4635     else {
4636         PUSHp(zero_but_true, ZBTLEN);
4637     }
4638     RETURN;
4639 #else
4640     return Perl_pp_semget(aTHX);
4641 #endif
4642 }
4643
4644 /* I can't const this further without getting warnings about the types of
4645    various arrays passed in from structures.  */
4646 static SV *
4647 S_space_join_names_mortal(pTHX_ char *const *array)
4648 {
4649     SV *target;
4650
4651     PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL;
4652
4653     if (array && *array) {
4654         target = newSVpvs_flags("", SVs_TEMP);
4655         while (1) {
4656             sv_catpv(target, *array);
4657             if (!*++array)
4658                 break;
4659             sv_catpvs(target, " ");
4660         }
4661     } else {
4662         target = sv_mortalcopy(&PL_sv_no);
4663     }
4664     return target;
4665 }
4666
4667 /* Get system info. */
4668
4669 PP(pp_ghostent)
4670 {
4671 #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
4672     dVAR; dSP;
4673     I32 which = PL_op->op_type;
4674     register char **elem;
4675     register SV *sv;
4676 #ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4677     struct hostent *gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4678     struct hostent *gethostbyname(Netdb_name_t);
4679     struct hostent *gethostent(void);
4680 #endif
4681     struct hostent *hent = NULL;
4682     unsigned long len;
4683
4684     EXTEND(SP, 10);
4685     if (which == OP_GHBYNAME) {
4686 #ifdef HAS_GETHOSTBYNAME
4687         const char* const name = POPpbytex;
4688         hent = PerlSock_gethostbyname(name);
4689 #else
4690         DIE(aTHX_ PL_no_sock_func, "gethostbyname");
4691 #endif
4692     }
4693     else if (which == OP_GHBYADDR) {
4694 #ifdef HAS_GETHOSTBYADDR
4695         const int addrtype = POPi;
4696         SV * const addrsv = POPs;
4697         STRLEN addrlen;
4698         const char *addr = (char *)SvPVbyte(addrsv, addrlen);
4699
4700         hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
4701 #else
4702         DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
4703 #endif
4704     }
4705     else
4706 #ifdef HAS_GETHOSTENT
4707         hent = PerlSock_gethostent();
4708 #else
4709         DIE(aTHX_ PL_no_sock_func, "gethostent");
4710 #endif
4711
4712 #ifdef HOST_NOT_FOUND
4713         if (!hent) {
4714 #ifdef USE_REENTRANT_API
4715 #   ifdef USE_GETHOSTENT_ERRNO
4716             h_errno = PL_reentrant_buffer->_gethostent_errno;
4717 #   endif
4718 #endif
4719             STATUS_UNIX_SET(h_errno);
4720         }
4721 #endif
4722
4723     if (GIMME != G_ARRAY) {
4724         PUSHs(sv = sv_newmortal());
4725         if (hent) {
4726             if (which == OP_GHBYNAME) {
4727                 if (hent->h_addr)
4728                     sv_setpvn(sv, hent->h_addr, hent->h_length);
4729             }
4730             else
4731                 sv_setpv(sv, (char*)hent->h_name);
4732         }
4733         RETURN;
4734     }
4735
4736     if (hent) {
4737         mPUSHs(newSVpv((char*)hent->h_name, 0));
4738         PUSHs(space_join_names_mortal(hent->h_aliases));
4739         mPUSHi(hent->h_addrtype);
4740         len = hent->h_length;
4741         mPUSHi(len);
4742 #ifdef h_addr
4743         for (elem = hent->h_addr_list; elem && *elem; elem++) {
4744             mXPUSHp(*elem, len);
4745         }
4746 #else
4747         if (hent->h_addr)
4748             mPUSHp(hent->h_addr, len);
4749         else
4750             PUSHs(sv_mortalcopy(&PL_sv_no));
4751 #endif /* h_addr */
4752     }
4753     RETURN;
4754 #else
4755     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4756 #endif
4757 }
4758
4759 PP(pp_gnetent)
4760 {
4761 #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
4762     dVAR; dSP;
4763     I32 which = PL_op->op_type;
4764     register SV *sv;
4765 #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4766     struct netent *getnetbyaddr(Netdb_net_t, int);
4767     struct netent *getnetbyname(Netdb_name_t);
4768     struct netent *getnetent(void);
4769 #endif
4770     struct netent *nent;
4771
4772     if (which == OP_GNBYNAME){
4773 #ifdef HAS_GETNETBYNAME
4774         const char * const name = POPpbytex;
4775         nent = PerlSock_getnetbyname(name);
4776 #else
4777         DIE(aTHX_ PL_no_sock_func, "getnetbyname");
4778 #endif
4779     }
4780     else if (which == OP_GNBYADDR) {
4781 #ifdef HAS_GETNETBYADDR
4782         const int addrtype = POPi;
4783         const Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
4784         nent = PerlSock_getnetbyaddr(addr, addrtype);
4785 #else
4786         DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
4787 #endif
4788     }
4789     else
4790 #ifdef HAS_GETNETENT
4791         nent = PerlSock_getnetent();
4792 #else
4793         DIE(aTHX_ PL_no_sock_func, "getnetent");
4794 #endif
4795
4796 #ifdef HOST_NOT_FOUND
4797         if (!nent) {
4798 #ifdef USE_REENTRANT_API
4799 #   ifdef USE_GETNETENT_ERRNO
4800              h_errno = PL_reentrant_buffer->_getnetent_errno;
4801 #   endif
4802 #endif
4803             STATUS_UNIX_SET(h_errno);
4804         }
4805 #endif
4806
4807     EXTEND(SP, 4);
4808     if (GIMME != G_ARRAY) {
4809         PUSHs(sv = sv_newmortal());
4810         if (nent) {
4811             if (which == OP_GNBYNAME)
4812                 sv_setiv(sv, (IV)nent->n_net);
4813             else
4814                 sv_setpv(sv, nent->n_name);
4815         }
4816         RETURN;
4817     }
4818
4819     if (nent) {
4820         mPUSHs(newSVpv(nent->n_name, 0));
4821         PUSHs(space_join_names_mortal(nent->n_aliases));
4822         mPUSHi(nent->n_addrtype);
4823         mPUSHi(nent->n_net);
4824     }
4825
4826     RETURN;
4827 #else
4828     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4829 #endif
4830 }
4831
4832 PP(pp_gprotoent)
4833 {
4834 #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
4835     dVAR; dSP;
4836     I32 which = PL_op->op_type;
4837     register SV *sv;
4838 #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4839     struct protoent *getprotobyname(Netdb_name_t);
4840     struct protoent *getprotobynumber(int);
4841     struct protoent *getprotoent(void);
4842 #endif
4843     struct protoent *pent;
4844
4845     if (which == OP_GPBYNAME) {
4846 #ifdef HAS_GETPROTOBYNAME
4847         const char* const name = POPpbytex;
4848         pent = PerlSock_getprotobyname(name);
4849 #else
4850         DIE(aTHX_ PL_no_sock_func, "getprotobyname");
4851 #endif
4852     }
4853     else if (which == OP_GPBYNUMBER) {
4854 #ifdef HAS_GETPROTOBYNUMBER
4855         const int number = POPi;
4856         pent = PerlSock_getprotobynumber(number);
4857 #else
4858         DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
4859 #endif
4860     }
4861     else
4862 #ifdef HAS_GETPROTOENT
4863         pent = PerlSock_getprotoent();
4864 #else
4865         DIE(aTHX_ PL_no_sock_func, "getprotoent");
4866 #endif
4867
4868     EXTEND(SP, 3);
4869     if (GIMME != G_ARRAY) {
4870         PUSHs(sv = sv_newmortal());
4871         if (pent) {
4872             if (which == OP_GPBYNAME)
4873                 sv_setiv(sv, (IV)pent->p_proto);
4874             else
4875                 sv_setpv(sv, pent->p_name);
4876         }
4877         RETURN;
4878     }
4879
4880     if (pent) {
4881         mPUSHs(newSVpv(pent->p_name, 0));
4882         PUSHs(space_join_names_mortal(pent->p_aliases));
4883         mPUSHi(pent->p_proto);
4884     }
4885
4886     RETURN;
4887 #else
4888     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4889 #endif
4890 }
4891
4892 PP(pp_gservent)
4893 {
4894 #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
4895     dVAR; dSP;
4896     I32 which = PL_op->op_type;
4897     register SV *sv;
4898 #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4899     struct servent *getservbyname(Netdb_name_t, Netdb_name_t);
4900     struct servent *getservbyport(int, Netdb_name_t);
4901     struct servent *getservent(void);
4902 #endif
4903     struct servent *sent;
4904
4905     if (which == OP_GSBYNAME) {
4906 #ifdef HAS_GETSERVBYNAME
4907         const char * const proto = POPpbytex;
4908         const char * const name = POPpbytex;
4909         sent = PerlSock_getservbyname(name, (proto && !*proto) ? NULL : proto);
4910 #else
4911         DIE(aTHX_ PL_no_sock_func, "getservbyname");
4912 #endif
4913     }
4914     else if (which == OP_GSBYPORT) {
4915 #ifdef HAS_GETSERVBYPORT
4916         const char * const proto = POPpbytex;
4917         unsigned short port = (unsigned short)POPu;
4918 #ifdef HAS_HTONS
4919         port = PerlSock_htons(port);
4920 #endif
4921         sent = PerlSock_getservbyport(port, (proto && !*proto) ? NULL : proto);
4922 #else
4923         DIE(aTHX_ PL_no_sock_func, "getservbyport");
4924 #endif
4925     }
4926     else
4927 #ifdef HAS_GETSERVENT
4928         sent = PerlSock_getservent();
4929 #else
4930         DIE(aTHX_ PL_no_sock_func, "getservent");
4931 #endif
4932
4933     EXTEND(SP, 4);
4934     if (GIMME != G_ARRAY) {
4935         PUSHs(sv = sv_newmortal());
4936         if (sent) {
4937             if (which == OP_GSBYNAME) {
4938 #ifdef HAS_NTOHS
4939                 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
4940 #else
4941                 sv_setiv(sv, (IV)(sent->s_port));
4942 #endif
4943             }
4944             else
4945                 sv_setpv(sv, sent->s_name);
4946         }
4947         RETURN;
4948     }
4949
4950     if (sent) {
4951         mPUSHs(newSVpv(sent->s_name, 0));
4952         PUSHs(space_join_names_mortal(sent->s_aliases));
4953 #ifdef HAS_NTOHS
4954         mPUSHi(PerlSock_ntohs(sent->s_port));
4955 #else
4956         mPUSHi(sent->s_port);
4957 #endif
4958         mPUSHs(newSVpv(sent->s_proto, 0));
4959     }
4960
4961     RETURN;
4962 #else
4963     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4964 #endif
4965 }
4966
4967 PP(pp_shostent)
4968 {
4969     dVAR; dSP;
4970     const int stayopen = TOPi;
4971     switch(PL_op->op_type) {
4972     case OP_SHOSTENT:
4973 #ifdef HAS_SETHOSTENT
4974         PerlSock_sethostent(stayopen);
4975 #else
4976         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4977 #endif
4978         break;
4979 #ifdef HAS_SETNETENT
4980     case OP_SNETENT:
4981         PerlSock_setnetent(stayopen);
4982 #else
4983         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4984 #endif
4985         break;
4986     case OP_SPROTOENT:
4987 #ifdef HAS_SETPROTOENT
4988         PerlSock_setprotoent(stayopen);
4989 #else
4990         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4991 #endif
4992         break;
4993     case OP_SSERVENT:
4994 #ifdef HAS_SETSERVENT
4995         PerlSock_setservent(stayopen);
4996 #else
4997         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
4998 #endif
4999         break;
5000     }
5001     RETSETYES;
5002 }
5003
5004 PP(pp_ehostent)
5005 {
5006     dVAR; dSP;
5007     switch(PL_op->op_type) {
5008     case OP_EHOSTENT:
5009 #ifdef HAS_ENDHOSTENT
5010         PerlSock_endhostent();
5011 #else
5012         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5013 #endif
5014         break;
5015     case OP_ENETENT:
5016 #ifdef HAS_ENDNETENT
5017         PerlSock_endnetent();
5018 #else
5019         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5020 #endif
5021         break;
5022     case OP_EPROTOENT:
5023 #ifdef HAS_ENDPROTOENT
5024         PerlSock_endprotoent();
5025 #else
5026         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5027 #endif
5028         break;
5029     case OP_ESERVENT:
5030 #ifdef HAS_ENDSERVENT
5031         PerlSock_endservent();
5032 #else
5033         DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
5034 #endif
5035         break;
5036     case OP_SGRENT:
5037 #if defined(HAS_GROUP) && defined(HAS_SETGRENT)
5038         setgrent();
5039 #else
5040         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5041 #endif
5042         break;
5043     case OP_EGRENT:
5044 #if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
5045         endgrent();
5046 #else
5047         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5048 #endif
5049         break;
5050     case OP_SPWENT:
5051 #if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
5052         setpwent();
5053 #else
5054         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5055 #endif
5056         break;
5057     case OP_EPWENT:
5058 #if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
5059         endpwent();
5060 #else
5061         DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
5062 #endif
5063         break;
5064     }
5065     EXTEND(SP,1);
5066     RETPUSHYES;
5067 }
5068
5069 PP(pp_gpwent)
5070 {
5071 #ifdef HAS_PASSWD
5072     dVAR; dSP;
5073     I32 which = PL_op->op_type;
5074     register SV *sv;
5075     struct passwd *pwent  = NULL;
5076     /*