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