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