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