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