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