Add S_save_pushptri32ptr() and use it to re-implement Perl_save_hints()
[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                 EXTEND(SP, 1000);
1813                 sv = sv_2mortal(newSViv(sv_len(*SP)));
1814                 PUSHs(sv);
1815                 PUTBACK;
1816             }
1817
1818             PUSHMARK(ORIGMARK);
1819             *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
1820             ENTER;
1821             call_method("WRITE", G_SCALAR);
1822             LEAVE;
1823             SPAGAIN;
1824             sv = POPs;
1825             SP = ORIGMARK;
1826             PUSHs(sv);
1827             RETURN;
1828         }
1829     }
1830     if (!gv)
1831         goto say_undef;
1832
1833     bufsv = *++MARK;
1834
1835     SETERRNO(0,0);
1836     io = GvIO(gv);
1837     if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
1838         retval = -1;
1839         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1840             if (io && IoIFP(io))
1841                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
1842             else
1843                 report_evil_fh(gv, io, PL_op->op_type);
1844         }
1845         SETERRNO(EBADF,RMS_IFI);
1846         goto say_undef;
1847     }
1848
1849     /* Do this first to trigger any overloading.  */
1850     buffer = SvPV_const(bufsv, blen);
1851     orig_blen_bytes = blen;
1852     doing_utf8 = DO_UTF8(bufsv);
1853
1854     if (PerlIO_isutf8(IoIFP(io))) {
1855         if (!SvUTF8(bufsv)) {
1856             /* We don't modify the original scalar.  */
1857             tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1858             buffer = (char *) tmpbuf;
1859             doing_utf8 = TRUE;
1860         }
1861     }
1862     else if (doing_utf8) {
1863         STRLEN tmplen = blen;
1864         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1865         if (!doing_utf8) {
1866             tmpbuf = result;
1867             buffer = (char *) tmpbuf;
1868             blen = tmplen;
1869         }
1870         else {
1871             assert((char *)result == buffer);
1872             Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1873         }
1874     }
1875
1876     if (op_type == OP_SYSWRITE) {
1877         Size_t length = 0; /* This length is in characters.  */
1878         STRLEN blen_chars;
1879         IV offset;
1880
1881         if (doing_utf8) {
1882             if (tmpbuf) {
1883                 /* The SV is bytes, and we've had to upgrade it.  */
1884                 blen_chars = orig_blen_bytes;
1885             } else {
1886                 /* The SV really is UTF-8.  */
1887                 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1888                     /* Don't call sv_len_utf8 again because it will call magic
1889                        or overloading a second time, and we might get back a
1890                        different result.  */
1891                     blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
1892                 } else {
1893                     /* It's safe, and it may well be cached.  */
1894                     blen_chars = sv_len_utf8(bufsv);
1895                 }
1896             }
1897         } else {
1898             blen_chars = blen;
1899         }
1900
1901         if (MARK >= SP) {
1902             length = blen_chars;
1903         } else {
1904 #if Size_t_size > IVSIZE
1905             length = (Size_t)SvNVx(*++MARK);
1906 #else
1907             length = (Size_t)SvIVx(*++MARK);
1908 #endif
1909             if ((SSize_t)length < 0) {
1910                 Safefree(tmpbuf);
1911                 DIE(aTHX_ "Negative length");
1912             }
1913         }
1914
1915         if (MARK < SP) {
1916             offset = SvIVx(*++MARK);
1917             if (offset < 0) {
1918                 if (-offset > (IV)blen_chars) {
1919                     Safefree(tmpbuf);
1920                     DIE(aTHX_ "Offset outside string");
1921                 }
1922                 offset += blen_chars;
1923             } else if (offset >= (IV)blen_chars && blen_chars > 0) {
1924                 Safefree(tmpbuf);
1925                 DIE(aTHX_ "Offset outside string");
1926             }
1927         } else
1928             offset = 0;
1929         if (length > blen_chars - offset)
1930             length = blen_chars - offset;
1931         if (doing_utf8) {
1932             /* Here we convert length from characters to bytes.  */
1933             if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1934                 /* Either we had to convert the SV, or the SV is magical, or
1935                    the SV has overloading, in which case we can't or mustn't
1936                    or mustn't call it again.  */
1937
1938                 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1939                 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1940             } else {
1941                 /* It's a real UTF-8 SV, and it's not going to change under
1942                    us.  Take advantage of any cache.  */
1943                 I32 start = offset;
1944                 I32 len_I32 = length;
1945
1946                 /* Convert the start and end character positions to bytes.
1947                    Remember that the second argument to sv_pos_u2b is relative
1948                    to the first.  */
1949                 sv_pos_u2b(bufsv, &start, &len_I32);
1950
1951                 buffer += start;
1952                 length = len_I32;
1953             }
1954         }
1955         else {
1956             buffer = buffer+offset;
1957         }
1958 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
1959         if (IoTYPE(io) == IoTYPE_SOCKET) {
1960             retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1961                                    buffer, length, 0);
1962         }
1963         else
1964 #endif
1965         {
1966             /* See the note at doio.c:do_print about filesize limits. --jhi */
1967             retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1968                                    buffer, length);
1969         }
1970     }
1971 #ifdef HAS_SOCKET
1972     else {
1973         const int flags = SvIVx(*++MARK);
1974         if (SP > MARK) {
1975             STRLEN mlen;
1976             char * const sockbuf = SvPVx(*++MARK, mlen);
1977             retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1978                                      flags, (struct sockaddr *)sockbuf, mlen);
1979         }
1980         else {
1981             retval
1982                 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1983         }
1984     }
1985 #else
1986     else
1987         DIE(aTHX_ PL_no_sock_func, "send");
1988 #endif
1989
1990     if (retval < 0)
1991         goto say_undef;
1992     SP = ORIGMARK;
1993     if (doing_utf8)
1994         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
1995
1996     Safefree(tmpbuf);
1997 #if Size_t_size > IVSIZE
1998     PUSHn(retval);
1999 #else
2000     PUSHi(retval);
2001 #endif
2002     RETURN;
2003
2004   say_undef:
2005     Safefree(tmpbuf);
2006     SP = ORIGMARK;
2007     RETPUSHUNDEF;
2008 }
2009
2010 PP(pp_eof)
2011 {
2012     dVAR; dSP;
2013     GV *gv;
2014
2015     if (MAXARG == 0) {
2016         if (PL_op->op_flags & OPf_SPECIAL) {    /* eof() */
2017             IO *io;
2018             gv = PL_last_in_gv = GvEGV(PL_argvgv);
2019             io = GvIO(gv);
2020             if (io && !IoIFP(io)) {
2021                 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2022                     IoLINES(io) = 0;
2023                     IoFLAGS(io) &= ~IOf_START;
2024                     do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2025                     if ( GvSV(gv) ) {
2026                         sv_setpvs(GvSV(gv), "-");
2027                     }
2028                     else {
2029                         GvSV(gv) = newSVpvs("-");
2030                     }
2031                     SvSETMAGIC(GvSV(gv));
2032                 }
2033                 else if (!nextargv(gv))
2034                     RETPUSHYES;
2035             }
2036         }
2037         else
2038             gv = PL_last_in_gv;                 /* eof */
2039     }
2040     else
2041         gv = PL_last_in_gv = MUTABLE_GV(POPs);  /* eof(FH) */
2042
2043     if (gv) {
2044         IO * const io = GvIO(gv);
2045         MAGIC * mg;
2046         if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
2047             PUSHMARK(SP);
2048             XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2049             PUTBACK;
2050             ENTER;
2051             call_method("EOF", G_SCALAR);
2052             LEAVE;
2053             SPAGAIN;
2054             RETURN;
2055         }
2056     }
2057
2058     PUSHs(boolSV(!gv || do_eof(gv)));
2059     RETURN;
2060 }
2061
2062 PP(pp_tell)
2063 {
2064     dVAR; dSP; dTARGET;
2065     GV *gv;
2066     IO *io;
2067
2068     if (MAXARG != 0)
2069         PL_last_in_gv = MUTABLE_GV(POPs);
2070     gv = PL_last_in_gv;
2071
2072     if (gv && (io = GvIO(gv))) {
2073         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2074         if (mg) {
2075             PUSHMARK(SP);
2076             XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2077             PUTBACK;
2078             ENTER;
2079             call_method("TELL", G_SCALAR);
2080             LEAVE;
2081             SPAGAIN;
2082             RETURN;
2083         }
2084     }
2085
2086 #if LSEEKSIZE > IVSIZE
2087     PUSHn( do_tell(gv) );
2088 #else
2089     PUSHi( do_tell(gv) );
2090 #endif
2091     RETURN;
2092 }
2093
2094 PP(pp_sysseek)
2095 {
2096     dVAR; dSP;
2097     const int whence = POPi;
2098 #if LSEEKSIZE > IVSIZE
2099     const Off_t offset = (Off_t)SvNVx(POPs);
2100 #else
2101     const Off_t offset = (Off_t)SvIVx(POPs);
2102 #endif
2103
2104     GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2105     IO *io;
2106
2107     if (gv && (io = GvIO(gv))) {
2108         MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2109         if (mg) {
2110             PUSHMARK(SP);
2111             XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
2112 #if LSEEKSIZE > IVSIZE
2113             mXPUSHn((NV) offset);
2114 #else
2115             mXPUSHi(offset);
2116 #endif
2117             mXPUSHi(whence);
2118             PUTBACK;
2119             ENTER;
2120             call_method("SEEK", G_SCALAR);
2121             LEAVE;
2122             SPAGAIN;
2123             RETURN;
2124         }
2125     }
2126
2127     if (PL_op->op_type == OP_SEEK)
2128         PUSHs(boolSV(do_seek(gv, offset, whence)));
2129     else {
2130         const Off_t sought = do_sysseek(gv, offset, whence);
2131         if (sought < 0)
2132             PUSHs(&PL_sv_undef);
2133         else {
2134             SV* const sv = sought ?
2135 #if LSEEKSIZE > IVSIZE
2136                 newSVnv((NV)sought)
2137 #else
2138                 newSViv(sought)
2139 #endif
2140                 : newSVpvn(zero_but_true, ZBTLEN);
2141             mPUSHs(sv);
2142         }
2143     }
2144     RETURN;
2145 }
2146
2147 PP(pp_truncate)
2148 {
2149     dVAR;
2150     dSP;
2151     /* There seems to be no consensus on the length type of truncate()
2152      * and ftruncate(), both off_t and size_t have supporters. In
2153      * general one would think that when using large files, off_t is
2154      * at least as wide as size_t, so using an off_t should be okay. */
2155     /* XXX Configure probe for the length type of *truncate() needed XXX */
2156     Off_t len;
2157
2158 #if Off_t_size > IVSIZE
2159     len = (Off_t)POPn;
2160 #else
2161     len = (Off_t)POPi;
2162 #endif
2163     /* Checking for length < 0 is problematic as the type might or
2164      * might not be signed: if it is not, clever compilers will moan. */
2165     /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2166     SETERRNO(0,0);
2167     {
2168         int result = 1;
2169         GV *tmpgv;
2170         IO *io;
2171
2172         if (PL_op->op_flags & OPf_SPECIAL) {
2173             tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
2174
2175         do_ftruncate_gv:
2176             if (!GvIO(tmpgv))
2177                 result = 0;
2178             else {
2179                 PerlIO *fp;
2180                 io = GvIOp(tmpgv);
2181             do_ftruncate_io:
2182                 TAINT_PROPER("truncate");
2183                 if (!(fp = IoIFP(io))) {
2184                     result = 0;
2185                 }
2186                 else {
2187                     PerlIO_flush(fp);
2188 #ifdef HAS_TRUNCATE
2189                     if (ftruncate(PerlIO_fileno(fp), len) < 0)
2190 #else
2191                     if (my_chsize(PerlIO_fileno(fp), len) < 0)
2192 #endif
2193                         result = 0;
2194                 }
2195             }
2196         }
2197         else {
2198             SV * const sv = POPs;
2199             const char *name;
2200
2201             if (isGV_with_GP(sv)) {
2202                 tmpgv = MUTABLE_GV(sv);         /* *main::FRED for example */
2203                 goto do_ftruncate_gv;
2204             }
2205             else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2206                 tmpgv = MUTABLE_GV(SvRV(sv));   /* \*main::FRED for example */
2207                 goto do_ftruncate_gv;
2208             }
2209             else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
2210                 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2211                 goto do_ftruncate_io;
2212             }
2213
2214             name = SvPV_nolen_const(sv);
2215             TAINT_PROPER("truncate");
2216 #ifdef HAS_TRUNCATE
2217             if (truncate(name, len) < 0)
2218                 result = 0;
2219 #else
2220             {
2221                 const int tmpfd = PerlLIO_open(name, O_RDWR);
2222
2223                 if (tmpfd < 0)
2224                     result = 0;
2225                 else {
2226                     if (my_chsize(tmpfd, len) < 0)
2227                         result = 0;
2228                     PerlLIO_close(tmpfd);
2229                 }
2230             }
2231 #endif
2232         }
2233
2234         if (result)
2235             RETPUSHYES;
2236         if (!errno)
2237             SETERRNO(EBADF,RMS_IFI);
2238         RETPUSHUNDEF;
2239     }
2240 }
2241
2242 PP(pp_ioctl)
2243 {
2244     dVAR; dSP; dTARGET;
2245     SV * const argsv = POPs;
2246     const unsigned int func = POPu;
2247     const int optype = PL_op->op_type;
2248     GV * const gv = MUTABLE_GV(POPs);
2249     IO * const io = gv ? GvIOn(gv) : NULL;
2250     char *s;
2251     IV retval;
2252
2253     if (!io || !argsv || !IoIFP(io)) {
2254         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2255             report_evil_fh(gv, io, PL_op->op_type);
2256         SETERRNO(EBADF,RMS_IFI);        /* well, sort of... */
2257         RETPUSHUNDEF;
2258     }
2259
2260     if (SvPOK(argsv) || !SvNIOK(argsv)) {
2261         STRLEN len;
2262         STRLEN need;
2263         s = SvPV_force(argsv, len);
2264         need = IOCPARM_LEN(func);
2265         if (len < need) {
2266             s = Sv_Grow(argsv, need + 1);
2267             SvCUR_set(argsv, need);
2268         }
2269
2270         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
2271     }
2272     else {
2273         retval = SvIV(argsv);
2274         s = INT2PTR(char*,retval);              /* ouch */
2275     }
2276
2277     TAINT_PROPER(PL_op_desc[optype]);
2278
2279     if (optype == OP_IOCTL)
2280 #ifdef HAS_IOCTL
2281         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2282 #else
2283         DIE(aTHX_ "ioctl is not implemented");
2284 #endif
2285     else
2286 #ifndef HAS_FCNTL
2287       DIE(aTHX_ "fcntl is not implemented");
2288 #else
2289 #if defined(OS2) && defined(__EMX__)
2290         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2291 #else
2292         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2293 #endif
2294 #endif
2295
2296 #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2297     if (SvPOK(argsv)) {
2298         if (s[SvCUR(argsv)] != 17)
2299             DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2300                 OP_NAME(PL_op));
2301         s[SvCUR(argsv)] = 0;            /* put our null back */
2302         SvSETMAGIC(argsv);              /* Assume it has changed */
2303     }
2304
2305     if (retval == -1)
2306         RETPUSHUNDEF;
2307     if (retval != 0) {
2308         PUSHi(retval);
2309     }
2310     else {
2311         PUSHp(zero_but_true, ZBTLEN);
2312     }
2313 #endif
2314     RETURN;
2315 }
2316
2317 PP(pp_flock)
2318 {
2319 #ifdef FLOCK
2320     dVAR; dSP; dTARGET;
2321     I32 value;
2322     IO *io = NULL;
2323     PerlIO *fp;
2324     const int argtype = POPi;
2325     GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
2326
2327     if (gv && (io = GvIO(gv)))
2328         fp = IoIFP(io);
2329     else {
2330         fp = NULL;
2331         io = NULL;
2332     }
2333     /* XXX Looks to me like io is always NULL at this point */
2334     if (fp) {
2335         (void)PerlIO_flush(fp);
2336         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2337     }
2338     else {
2339         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2340             report_evil_fh(gv, io, PL_op->op_type);
2341         value = 0;
2342         SETERRNO(EBADF,RMS_IFI);
2343     }
2344     PUSHi(value);
2345     RETURN;
2346 #else
2347     DIE(aTHX_ PL_no_func, "flock()");
2348 #endif
2349 }
2350
2351 /* Sockets. */
2352
2353 PP(pp_socket)
2354 {
2355 #ifdef HAS_SOCKET
2356     dVAR; dSP;
2357     const int protocol = POPi;
2358     const int type = POPi;
2359     const int domain = POPi;
2360     GV * const gv = MUTABLE_GV(POPs);
2361     register IO * const io = gv ? GvIOn(gv) : NULL;
2362     int fd;
2363
2364     if (!gv || !io) {
2365         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2366             report_evil_fh(gv, io, PL_op->op_type);
2367         if (io && IoIFP(io))
2368             do_close(gv, FALSE);
2369         SETERRNO(EBADF,LIB_INVARG);
2370         RETPUSHUNDEF;
2371     }
2372
2373     if (IoIFP(io))
2374         do_close(gv, FALSE);
2375
2376     TAINT_PROPER("socket");
2377     fd = PerlSock_socket(domain, type, protocol);
2378     if (fd < 0)
2379         RETPUSHUNDEF;
2380     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2381     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2382     IoTYPE(io) = IoTYPE_SOCKET;
2383     if (!IoIFP(io) || !IoOFP(io)) {
2384         if (IoIFP(io)) PerlIO_close(IoIFP(io));
2385         if (IoOFP(io)) PerlIO_close(IoOFP(io));
2386         if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
2387         RETPUSHUNDEF;
2388     }
2389 #if defined(HAS_FCNTL) && defined(F_SETFD)
2390     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2391 #endif
2392
2393 #ifdef EPOC
2394     setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2395 #endif
2396
2397     RETPUSHYES;
2398 #else
2399     DIE(aTHX_ PL_no_sock_func, "socket");
2400 #endif
2401 }
2402
2403 PP(pp_sockpair)
2404 {
2405 #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2406     dVAR; dSP;
2407     const int protocol = POPi;
2408     const int type = POPi;
2409     const int domain = POPi;
2410     GV * const gv2 = MUTABLE_GV(POPs);
2411     GV * const gv1 = MUTABLE_GV(POPs);
2412     register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2413     register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
2414     int fd[2];
2415
2416     if (!gv1 || !gv2 || !io1 || !io2) {
2417         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2418             if (!gv1 || !io1)
2419                 report_evil_fh(gv1, io1, PL_op->op_type);
2420             if (!gv2 || !io2)
2421                 report_evil_fh(gv1, io2, PL_op->op_type);
2422         }
2423         if (io1 && IoIFP(io1))
2424             do_close(gv1, FALSE);
2425         if (io2 && IoIFP(io2))
2426             do_close(gv2, FALSE);
2427         RETPUSHUNDEF;
2428     }
2429
2430     if (IoIFP(io1))
2431         do_close(gv1, FALSE);
2432     if (IoIFP(io2))
2433         do_close(gv2, FALSE);
2434
2435     TAINT_PROPER("socketpair");
2436     if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2437         RETPUSHUNDEF;
2438     IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2439     IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2440     IoTYPE(io1) = IoTYPE_SOCKET;
2441     IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2442     IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2443     IoTYPE(io2) = IoTYPE_SOCKET;
2444     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
2445         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2446         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2447         if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
2448         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2449         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2450         if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
2451         RETPUSHUNDEF;
2452     }
2453 #if defined(HAS_FCNTL) && defined(F_SETFD)
2454     fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);   /* ensure close-on-exec */
2455     fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);   /* ensure close-on-exec */
2456 #endif
2457
2458     RETPUSHYES;
2459 #else
2460     DIE(aTHX_ PL_no_sock_func, "socketpair");
2461 #endif
2462 }
2463
2464 PP(pp_bind)
2465 {
2466 #ifdef HAS_SOCKET
2467     dVAR; dSP;
2468     SV * const addrsv = POPs;
2469     /* OK, so on what platform does bind modify addr?  */
2470     const char *addr;
2471     GV * const gv = MUTABLE_GV(POPs);
2472     register IO * const io = GvIOn(gv);
2473     STRLEN len;
2474
2475     if (!io || !IoIFP(io))
2476         goto nuts;
2477
2478     addr = SvPV_const(addrsv, len);
2479     TAINT_PROPER("bind");
2480     if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2481         RETPUSHYES;
2482     else
2483         RETPUSHUNDEF;
2484
2485 nuts:
2486     if (ckWARN(WARN_CLOSED))
2487         report_evil_fh(gv, io, PL_op->op_type);
2488     SETERRNO(EBADF,SS_IVCHAN);
2489     RETPUSHUNDEF;
2490 #else
2491     DIE(aTHX_ PL_no_sock_func, "bind");
2492 #endif
2493 }
2494
2495 PP(pp_connect)
2496 {
2497 #ifdef HAS_SOCKET
2498     dVAR; dSP;
2499     SV * const addrsv = POPs;
2500     GV * const gv = MUTABLE_GV(POPs);
2501     register IO * const io = GvIOn(gv);
2502     const char *addr;
2503     STRLEN len;
2504
2505     if (!io || !IoIFP(io))
2506         goto nuts;
2507
2508     addr = SvPV_const(addrsv, len);
2509     TAINT_PROPER("connect");
2510     if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
2511         RETPUSHYES;
2512     else
2513         RETPUSHUNDEF;
2514
2515 nuts:
2516     if (ckWARN(WARN_CLOSED))
2517         report_evil_fh(gv, io, PL_op->op_type);
2518     SETERRNO(EBADF,SS_IVCHAN);
2519     RETPUSHUNDEF;
2520 #else
2521     DIE(aTHX_ PL_no_sock_func, "connect");
2522 #endif
2523 }
2524
2525 PP(pp_listen)
2526 {
2527 #ifdef HAS_SOCKET
2528     dVAR; dSP;
2529     const int backlog = POPi;
2530     GV * const gv = MUTABLE_GV(POPs);
2531     register IO * const io = gv ? GvIOn(gv) : NULL;
2532
2533     if (!gv || !io || !IoIFP(io))
2534         goto nuts;
2535
2536     if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2537         RETPUSHYES;
2538     else
2539         RETPUSHUNDEF;
2540
2541 nuts:
2542     if (ckWARN(WARN_CLOSED))
2543         report_evil_fh(gv, io, PL_op->op_type);
2544     SETERRNO(EBADF,SS_IVCHAN);
2545     RETPUSHUNDEF;
2546 #else
2547     DIE(aTHX_ PL_no_sock_func, "listen");
2548 #endif
2549 }
2550
2551 PP(pp_accept)
2552 {
2553 #ifdef HAS_SOCKET
2554     dVAR; dSP; dTARGET;
2555     register IO *nstio;
2556     register IO *gstio;
2557     char namebuf[MAXPATHLEN];
2558 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2559     Sock_size_t len = sizeof (struct sockaddr_in);
2560 #else
2561     Sock_size_t len = sizeof namebuf;
2562 #endif
2563     GV * const ggv = MUTABLE_GV(POPs);
2564     GV * const ngv = MUTABLE_GV(POPs);
2565     int fd;
2566
2567     if (!ngv)
2568         goto badexit;
2569     if (!ggv)
2570         goto nuts;
2571
2572     gstio = GvIO(ggv);
2573     if (!gstio || !IoIFP(gstio))
2574         goto nuts;
2575
2576     nstio = GvIOn(ngv);
2577     fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2578 #if defined(OEMVS)
2579     if (len == 0) {
2580         /* Some platforms indicate zero length when an AF_UNIX client is
2581          * not bound. Simulate a non-zero-length sockaddr structure in
2582          * this case. */
2583         namebuf[0] = 0;        /* sun_len */
2584         namebuf[1] = AF_UNIX;  /* sun_family */
2585         len = 2;
2586     }
2587 #endif
2588
2589     if (fd < 0)
2590         goto badexit;
2591     if (IoIFP(nstio))
2592         do_close(ngv, FALSE);
2593     IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2594     IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2595     IoTYPE(nstio) = IoTYPE_SOCKET;
2596     if (!IoIFP(nstio) || !IoOFP(nstio)) {
2597         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2598         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2599         if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
2600         goto badexit;
2601     }
2602 #if defined(HAS_FCNTL) && defined(F_SETFD)
2603     fcntl(fd, F_SETFD, fd > PL_maxsysfd);       /* ensure close-on-exec */
2604 #endif
2605
2606 #ifdef EPOC
2607     len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
2608     setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
2609 #endif
2610 #ifdef __SCO_VERSION__
2611     len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2612 #endif
2613
2614     PUSHp(namebuf, len);
2615     RETURN;
2616
2617 nuts:
2618     if (ckWARN(WARN_CLOSED))
2619         report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
2620     SETERRNO(EBADF,SS_IVCHAN);
2621
2622 badexit:
2623     RETPUSHUNDEF;
2624
2625 #else
2626     DIE(aTHX_ PL_no_sock_func, "accept");
2627 #endif
2628 }
2629
2630 PP(pp_shutdown)
2631 {
2632 #ifdef HAS_SOCKET
2633     dVAR; dSP; dTARGET;
2634     const int how = POPi;
2635     GV * const gv = MUTABLE_GV(POPs);
2636     register IO * const io = GvIOn(gv);
2637
2638     if (!io || !IoIFP(io))
2639         goto nuts;
2640
2641     PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2642     RETURN;
2643
2644 nuts:
2645     if (ckWARN(WARN_CLOSED))
2646         report_evil_fh(gv, io, PL_op->op_type);
2647     SETERRNO(EBADF,SS_IVCHAN);
2648     RETPUSHUNDEF;
2649 #else
2650     DIE(aTHX_ PL_no_sock_func, "shutdown");
2651 #endif
2652 }
2653
2654 PP(pp_ssockopt)
2655 {
2656 #ifdef HAS_SOCKET
2657     dVAR; dSP;
2658     const int optype = PL_op->op_type;
2659     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2660     const unsigned int optname = (unsigned int) POPi;
2661     const unsigned int lvl = (unsigned int) POPi;
2662     GV * const gv = MUTABLE_GV(POPs);
2663     register IO * const io = GvIOn(gv);
2664     int fd;
2665     Sock_size_t len;
2666
2667     if (!io || !IoIFP(io))
2668         goto nuts;
2669
2670     fd = PerlIO_fileno(IoIFP(io));
2671     switch (optype) {
2672     case OP_GSOCKOPT:
2673         SvGROW(sv, 257);
2674         (void)SvPOK_only(sv);
2675         SvCUR_set(sv,256);
2676         *SvEND(sv) ='\0';
2677         len = SvCUR(sv);
2678         if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2679             goto nuts2;
2680         SvCUR_set(sv, len);
2681         *SvEND(sv) ='\0';
2682         PUSHs(sv);
2683         break;
2684     case OP_SSOCKOPT: {
2685 #if defined(__SYMBIAN32__)
2686 # define SETSOCKOPT_OPTION_VALUE_T void *
2687 #else
2688 # define SETSOCKOPT_OPTION_VALUE_T const char *
2689 #endif
2690         /* XXX TODO: We need to have a proper type (a Configure probe,
2691          * etc.) for what the C headers think of the third argument of
2692          * setsockopt(), the option_value read-only buffer: is it
2693          * a "char *", or a "void *", const or not.  Some compilers
2694          * don't take kindly to e.g. assuming that "char *" implicitly
2695          * promotes to a "void *", or to explicitly promoting/demoting
2696          * consts to non/vice versa.  The "const void *" is the SUS
2697          * definition, but that does not fly everywhere for the above
2698          * reasons. */
2699             SETSOCKOPT_OPTION_VALUE_T buf;
2700             int aint;
2701             if (SvPOKp(sv)) {
2702                 STRLEN l;
2703                 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2704                 len = l;
2705             }
2706             else {
2707                 aint = (int)SvIV(sv);
2708                 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2709                 len = sizeof(int);
2710             }
2711             if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2712                 goto nuts2;
2713             PUSHs(&PL_sv_yes);
2714         }
2715         break;
2716     }
2717     RETURN;
2718
2719 nuts:
2720     if (ckWARN(WARN_CLOSED))
2721         report_evil_fh(gv, io, optype);
2722     SETERRNO(EBADF,SS_IVCHAN);
2723 nuts2:
2724     RETPUSHUNDEF;
2725
2726 #else
2727     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2728 #endif
2729 }
2730
2731 PP(pp_getpeername)
2732 {
2733 #ifdef HAS_SOCKET
2734     dVAR; dSP;
2735     const int optype = PL_op->op_type;
2736     GV * const gv = MUTABLE_GV(POPs);
2737     register IO * const io = GvIOn(gv);
2738     Sock_size_t len;
2739     SV *sv;
2740     int fd;
2741
2742     if (!io || !IoIFP(io))
2743         goto nuts;
2744
2745     sv = sv_2mortal(newSV(257));
2746     (void)SvPOK_only(sv);
2747     len = 256;
2748     SvCUR_set(sv, len);
2749     *SvEND(sv) ='\0';
2750     fd = PerlIO_fileno(IoIFP(io));
2751     switch (optype) {
2752     case OP_GETSOCKNAME:
2753         if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2754             goto nuts2;
2755         break;
2756     case OP_GETPEERNAME:
2757         if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2758             goto nuts2;
2759 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2760         {
2761             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";
2762             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2763             if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2764                 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2765                         sizeof(u_short) + sizeof(struct in_addr))) {
2766                 goto nuts2;     
2767             }
2768         }
2769 #endif
2770         break;
2771     }
2772 #ifdef BOGUS_GETNAME_RETURN
2773     /* Interactive Unix, getpeername() and getsockname()
2774       does not return valid namelen */
2775     if (len == BOGUS_GETNAME_RETURN)
2776         len = sizeof(struct sockaddr);
2777 #endif
2778     SvCUR_set(sv, len);
2779     *SvEND(sv) ='\0';
2780     PUSHs(sv);
2781     RETURN;
2782
2783 nuts:
2784     if (ckWARN(WARN_CLOSED))
2785         report_evil_fh(gv, io, optype);
2786     SETERRNO(EBADF,SS_IVCHAN);
2787 nuts2:
2788     RETPUSHUNDEF;
2789
2790 #else
2791     DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
2792 #endif
2793 }
2794
2795 /* Stat calls. */
2796
2797 PP(pp_stat)
2798 {
2799     dVAR;
2800     dSP;
2801     GV *gv = NULL;
2802     IO *io;
2803     I32 gimme;
2804     I32 max = 13;
2805
2806     if (PL_op->op_flags & OPf_REF) {
2807         gv = cGVOP_gv;
2808         if (PL_op->op_type == OP_LSTAT) {
2809             if (gv != PL_defgv) {
2810             do_fstat_warning_check:
2811                 if (ckWARN(WARN_IO))
2812                     Perl_warner(aTHX_ packWARN(WARN_IO),
2813                         "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
2814             } else if (PL_laststype != OP_LSTAT)
2815                 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2816         }
2817
2818       do_fstat:
2819         if (gv != PL_defgv) {
2820             PL_laststype = OP_STAT;
2821             PL_statgv = gv;
2822             sv_setpvs(PL_statname, "");
2823             if(gv) {
2824                 io = GvIO(gv);
2825                 do_fstat_have_io:
2826                 if (io) {
2827                     if (IoIFP(io)) {
2828                         PL_laststatval = 
2829                             PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
2830                     } else if (IoDIRP(io)) {
2831                         PL_laststatval =
2832                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2833                     } else {
2834                         PL_laststatval = -1;
2835                     }
2836                 }
2837             }
2838         }
2839
2840         if (PL_laststatval < 0) {
2841             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2842                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
2843             max = 0;
2844         }
2845     }
2846     else {
2847         SV* const sv = POPs;
2848         if (isGV_with_GP(sv)) {
2849             gv = MUTABLE_GV(sv);
2850             goto do_fstat;
2851         } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
2852             gv = MUTABLE_GV(SvRV(sv));
2853             if (PL_op->op_type == OP_LSTAT)
2854                 goto do_fstat_warning_check;
2855             goto do_fstat;
2856         } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
2857             io = MUTABLE_IO(SvRV(sv));
2858             if (PL_op->op_type == OP_LSTAT)
2859                 goto do_fstat_warning_check;
2860             goto do_fstat_have_io; 
2861         }
2862         
2863         sv_setpv(PL_statname, SvPV_nolen_const(sv));
2864         PL_statgv = NULL;
2865         PL_laststype = PL_op->op_type;
2866         if (PL_op->op_type == OP_LSTAT)
2867             PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2868         else
2869             PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2870         if (PL_laststatval < 0) {
2871             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
2872                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2873             max = 0;
2874         }
2875     }
2876
2877     gimme = GIMME_V;
2878     if (gimme != G_ARRAY) {
2879         if (gimme != G_VOID)
2880             XPUSHs(boolSV(max));
2881         RETURN;
2882     }
2883     if (max) {
2884         EXTEND(SP, max);
2885         EXTEND_MORTAL(max);
2886         mPUSHi(PL_statcache.st_dev);
2887         mPUSHi(PL_statcache.st_ino);
2888         mPUSHu(PL_statcache.st_mode);
2889         mPUSHu(PL_statcache.st_nlink);
2890 #if Uid_t_size > IVSIZE
2891         mPUSHn(PL_statcache.st_uid);
2892 #else
2893 #   if Uid_t_sign <= 0
2894         mPUSHi(PL_statcache.st_uid);
2895 #   else
2896         mPUSHu(PL_statcache.st_uid);
2897 #   endif
2898 #endif
2899 #if Gid_t_size > IVSIZE
2900         mPUSHn(PL_statcache.st_gid);
2901 #else
2902 #   if Gid_t_sign <= 0
2903         mPUSHi(PL_statcache.st_gid);
2904 #   else
2905         mPUSHu(PL_statcache.st_gid);
2906 #   endif
2907 #endif
2908 #ifdef USE_STAT_RDEV
2909         mPUSHi(PL_statcache.st_rdev);
2910 #else
2911         PUSHs(newSVpvs_flags("", SVs_TEMP));
2912 #endif
2913 #if Off_t_size > IVSIZE
2914         mPUSHn(PL_statcache.st_size);
2915 #else
2916         mPUSHi(PL_statcache.st_size);
2917 #endif
2918 #ifdef BIG_TIME
2919         mPUSHn(PL_statcache.st_atime);
2920         mPUSHn(PL_statcache.st_mtime);
2921         mPUSHn(PL_statcache.st_ctime);
2922 #else
2923         mPUSHi(PL_statcache.st_atime);
2924         mPUSHi(PL_statcache.st_mtime);
2925         mPUSHi(PL_statcache.st_ctime);
2926 #endif
2927 #ifdef USE_STAT_BLOCKS
2928         mPUSHu(PL_statcache.st_blksize);
2929         mPUSHu(PL_statcache.st_blocks);
2930 #else
2931         PUSHs(newSVpvs_flags("", SVs_TEMP));
2932         PUSHs(newSVpvs_flags("", SVs_TEMP));
2933 #endif
2934     }
2935     RETURN;
2936 }
2937
2938 /* This macro is used by the stacked filetest operators :
2939  * if the previous filetest failed, short-circuit and pass its value.
2940  * Else, discard it from the stack and continue. --rgs
2941  */
2942 #define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
2943         if (!SvTRUE(TOPs)) { RETURN; } \
2944         else { (void)POPs; PUTBACK; } \
2945     }
2946
2947 PP(pp_ftrread)
2948 {
2949     dVAR;
2950     I32 result;
2951     /* Not const, because things tweak this below. Not bool, because there's
2952        no guarantee that OPp_FT_ACCESS is <= CHAR_MAX  */
2953 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2954     I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2955     /* Giving some sort of initial value silences compilers.  */
2956 #  ifdef R_OK
2957     int access_mode = R_OK;
2958 #  else
2959     int access_mode = 0;
2960 #  endif
2961 #else
2962     /* access_mode is never used, but leaving use_access in makes the
2963        conditional compiling below much clearer.  */
2964     I32 use_access = 0;
2965 #endif
2966     int stat_mode = S_IRUSR;
2967
2968     bool effective = FALSE;
2969     dSP;
2970
2971     STACKED_FTEST_CHECK;
2972
2973     switch (PL_op->op_type) {
2974     case OP_FTRREAD:
2975 #if !(defined(HAS_ACCESS) && defined(R_OK))
2976         use_access = 0;
2977 #endif
2978         break;
2979
2980     case OP_FTRWRITE:
2981 #if defined(HAS_ACCESS) && defined(W_OK)
2982         access_mode = W_OK;
2983 #else
2984         use_access = 0;
2985 #endif
2986         stat_mode = S_IWUSR;
2987         break;
2988
2989     case OP_FTREXEC:
2990 #if defined(HAS_ACCESS) && defined(X_OK)
2991         access_mode = X_OK;
2992 #else
2993         use_access = 0;
2994 #endif
2995         stat_mode = S_IXUSR;
2996         break;
2997
2998     case OP_FTEWRITE:
2999 #ifdef PERL_EFF_ACCESS
3000         access_mode = W_OK;
3001 #endif
3002         stat_mode = S_IWUSR;
3003         /* Fall through  */
3004
3005     case OP_FTEREAD:
3006 #ifndef PERL_EFF_ACCESS
3007         use_access = 0;
3008 #endif
3009         effective = TRUE;
3010         break;
3011
3012     case OP_FTEEXEC:
3013 #ifdef PERL_EFF_ACCESS
3014         access_mode = X_OK;
3015 #else
3016         use_access = 0;
3017 #endif
3018         stat_mode = S_IXUSR;
3019         effective = TRUE;
3020         break;
3021     }
3022
3023     if (use_access) {
3024 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3025         const char *name = POPpx;
3026         if (effective) {
3027 #  ifdef PERL_EFF_ACCESS
3028             result = PERL_EFF_ACCESS(name, access_mode);
3029 #  else
3030             DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3031                 OP_NAME(PL_op));
3032 #  endif
3033         }
3034         else {
3035 #  ifdef HAS_ACCESS
3036             result = access(name, access_mode);
3037 #  else
3038             DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3039 #  endif
3040         }
3041         if (result == 0)
3042             RETPUSHYES;
3043         if (result < 0)
3044             RETPUSHUNDEF;
3045         RETPUSHNO;
3046 #endif
3047     }
3048
3049     result = my_stat();
3050     SPAGAIN;
3051     if (result < 0)
3052         RETPUSHUNDEF;
3053     if (cando(stat_mode, effective, &PL_statcache))
3054         RETPUSHYES;
3055     RETPUSHNO;
3056 }
3057
3058 PP(pp_ftis)
3059 {
3060     dVAR;
3061     I32 result;
3062     const int op_type = PL_op->op_type;
3063     dSP;
3064     STACKED_FTEST_CHECK;
3065     result = my_stat();
3066     SPAGAIN;
3067     if (result < 0)
3068         RETPUSHUNDEF;
3069     if (op_type == OP_FTIS)
3070         RETPUSHYES;
3071     {
3072         /* You can't dTARGET inside OP_FTIS, because you'll get
3073            "panic: pad_sv po" - the op is not flagged to have a target.  */
3074         dTARGET;
3075         switch (op_type) {
3076         case OP_FTSIZE:
3077 #if Off_t_size > IVSIZE
3078             PUSHn(PL_statcache.st_size);
3079 #else
3080             PUSHi(PL_statcache.st_size);
3081 #endif
3082             break;
3083         case OP_FTMTIME:
3084             PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3085             break;
3086         case OP_FTATIME:
3087             PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3088             break;
3089         case OP_FTCTIME:
3090             PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3091             break;
3092         }
3093     }
3094     RETURN;
3095 }
3096
3097 PP(pp_ftrowned)
3098 {
3099     dVAR;
3100     I32 result;
3101     dSP;
3102
3103     /* I believe that all these three are likely to be defined on most every
3104        system these days.  */
3105 #ifndef S_ISUID
3106     if(PL_op->op_type == OP_FTSUID)
3107         RETPUSHNO;
3108 #endif
3109 #ifndef S_ISGID
3110     if(PL_op->op_type == OP_FTSGID)
3111         RETPUSHNO;
3112 #endif
3113 #ifndef S_ISVTX
3114     if(PL_op->op_type == OP_FTSVTX)
3115         RETPUSHNO;
3116 #endif
3117
3118     STACKED_FTEST_CHECK;
3119     result = my_stat();
3120     SPAGAIN;
3121     if (result < 0)
3122         RETPUSHUNDEF;
3123     switch (PL_op->op_type) {
3124     case OP_FTROWNED:
3125         if (PL_statcache.st_uid == PL_uid)
3126             RETPUSHYES;
3127         break;
3128     case OP_FTEOWNED:
3129         if (PL_statcache.st_uid == PL_euid)
3130             RETPUSHYES;
3131         break;
3132     case OP_FTZERO:
3133         if (PL_statcache.st_size == 0)
3134             RETPUSHYES;
3135         break;
3136     case OP_FTSOCK:
3137         if (S_ISSOCK(PL_statcache.st_mode))
3138             RETPUSHYES;
3139         break;
3140     case OP_FTCHR:
3141         if (S_ISCHR(PL_statcache.st_mode))
3142             RETPUSHYES;
3143         break;
3144     case OP_FTBLK:
3145         if (S_ISBLK(PL_statcache.st_mode))
3146             RETPUSHYES;
3147         break;
3148     case OP_FTFILE:
3149         if (S_ISREG(PL_statcache.st_mode))
3150             RETPUSHYES;
3151         break;
3152     case OP_FTDIR:
3153         if (S_ISDIR(PL_statcache.st_mode))
3154             RETPUSHYES;
3155         break;
3156     case OP_FTPIPE:
3157         if (S_ISFIFO(PL_statcache.st_mode))
3158             RETPUSHYES;
3159         break;
3160 #ifdef S_ISUID
3161     case OP_FTSUID:
3162         if (PL_statcache.st_mode & S_ISUID)
3163             RETPUSHYES;
3164         break;
3165 #endif
3166 #ifdef S_ISGID
3167     case OP_FTSGID:
3168         if (PL_statcache.st_mode & S_ISGID)
3169             RETPUSHYES;
3170         break;
3171 #endif
3172 #ifdef S_ISVTX
3173     case OP_FTSVTX:
3174         if (PL_statcache.st_mode & S_ISVTX)
3175             RETPUSHYES;
3176         break;
3177 #endif
3178     }
3179     RETPUSHNO;
3180 }
3181
3182 PP(pp_ftlink)
3183 {
3184     dVAR;
3185     I32 result = my_lstat();
3186     dSP;
3187     if (result < 0)
3188         RETPUSHUNDEF;
3189     if (S_ISLNK(PL_statcache.st_mode))
3190         RETPUSHYES;
3191     RETPUSHNO;
3192 }
3193
3194 PP(pp_fttty)
3195 {
3196     dVAR;
3197     dSP;
3198     int fd;
3199     GV *gv;
3200     SV *tmpsv = NULL;
3201
3202     STACKED_FTEST_CHECK;
3203
3204     if (PL_op->op_flags & OPf_REF)
3205         gv = cGVOP_gv;
3206     else if (isGV(TOPs))
3207         gv = MUTABLE_GV(POPs);
3208     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3209         gv = MUTABLE_GV(SvRV(POPs));
3210     else
3211         gv = gv_fetchsv(tmpsv = POPs, 0, SVt_PVIO);
3212
3213     if (GvIO(gv) && IoIFP(GvIOp(gv)))
3214         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3215     else if (tmpsv && SvOK(tmpsv)) {
3216         const char *tmps = SvPV_nolen_const(tmpsv);
3217         if (isDIGIT(*tmps))
3218             fd = atoi(tmps);
3219         else 
3220             RETPUSHUNDEF;
3221     }
3222     else
3223         RETPUSHUNDEF;
3224     if (PerlLIO_isatty(fd))
3225         RETPUSHYES;
3226     RETPUSHNO;
3227 }
3228
3229 #if defined(atarist) /* this will work with atariST. Configure will
3230                         make guesses for other systems. */
3231 # define FILE_base(f) ((f)->_base)
3232 # define FILE_ptr(f) ((f)->_ptr)
3233 # define FILE_cnt(f) ((f)->_cnt)
3234 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
3235 #endif
3236
3237 PP(pp_fttext)
3238 {
3239     dVAR;
3240     dSP;
3241     I32 i;
3242     I32 len;
3243     I32 odd = 0;
3244     STDCHAR tbuf[512];
3245     register STDCHAR *s;
3246     register IO *io;
3247     register SV *sv;
3248     GV *gv;
3249     PerlIO *fp;
3250
3251     STACKED_FTEST_CHECK;
3252
3253     if (PL_op->op_flags & OPf_REF)
3254         gv = cGVOP_gv;
3255     else if (isGV(TOPs))
3256         gv = MUTABLE_GV(POPs);
3257     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3258         gv = MUTABLE_GV(SvRV(POPs));
3259     else
3260         gv = NULL;
3261
3262     if (gv) {
3263         EXTEND(SP, 1);
3264         if (gv == PL_defgv) {
3265             if (PL_statgv)
3266                 io = GvIO(PL_statgv);
3267             else {
3268                 sv = PL_statname;
3269                 goto really_filename;
3270             }
3271         }
3272         else {
3273             PL_statgv = gv;
3274             PL_laststatval = -1;
3275             sv_setpvs(PL_statname, "");
3276             io = GvIO(PL_statgv);
3277         }
3278         if (io && IoIFP(io)) {
3279             if (! PerlIO_has_base(IoIFP(io)))
3280                 DIE(aTHX_ "-T and -B not implemented on filehandles");
3281             PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3282             if (PL_laststatval < 0)
3283                 RETPUSHUNDEF;
3284             if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3285                 if (PL_op->op_type == OP_FTTEXT)
3286                     RETPUSHNO;
3287                 else
3288                     RETPUSHYES;
3289             }
3290             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3291                 i = PerlIO_getc(IoIFP(io));
3292                 if (i != EOF)
3293                     (void)PerlIO_ungetc(IoIFP(io),i);
3294             }
3295             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3296                 RETPUSHYES;
3297             len = PerlIO_get_bufsiz(IoIFP(io));
3298             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3299             /* sfio can have large buffers - limit to 512 */
3300             if (len > 512)
3301                 len = 512;
3302         }
3303         else {
3304             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
3305                 gv = cGVOP_gv;
3306                 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
3307             }
3308             SETERRNO(EBADF,RMS_IFI);
3309             RETPUSHUNDEF;
3310         }
3311     }
3312     else {
3313         sv = POPs;
3314       really_filename:
3315         PL_statgv = NULL;
3316         PL_laststype = OP_STAT;
3317         sv_setpv(PL_statname, SvPV_nolen_const(sv));
3318         if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3319             if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3320                                                '\n'))
3321                 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3322             RETPUSHUNDEF;
3323         }
3324         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3325         if (PL_laststatval < 0) {
3326             (void)PerlIO_close(fp);
3327             RETPUSHUNDEF;
3328         }
3329         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3330         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3331         (void)PerlIO_close(fp);
3332         if (len <= 0) {
3333             if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
3334                 RETPUSHNO;              /* special case NFS directories */
3335             RETPUSHYES;         /* null file is anything */
3336         }
3337         s = tbuf;
3338     }
3339
3340     /* now scan s to look for textiness */
3341     /*   XXX ASCII dependent code */
3342
3343 #if defined(DOSISH) || defined(USEMYBINMODE)
3344     /* ignore trailing ^Z on short files */
3345     if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3346         --len;
3347 #endif
3348
3349     for (i = 0; i < len; i++, s++) {
3350         if (!*s) {                      /* null never allowed in text */
3351             odd += len;
3352             break;
3353         }
3354 #ifdef EBCDIC
3355         else if (!(isPRINT(*s) || isSPACE(*s)))
3356             odd++;
3357 #else
3358         else if (*s & 128) {
3359 #ifdef USE_LOCALE
3360             if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
3361                 continue;
3362 #endif
3363             /* utf8 characters don't count as odd */
3364             if (UTF8_IS_START(*s)) {
3365                 int ulen = UTF8SKIP(s);
3366                 if (ulen < len - i) {
3367                     int j;
3368                     for (j = 1; j < ulen; j++) {
3369                         if (!UTF8_IS_CONTINUATION(s[j]))
3370                             goto not_utf8;
3371                     }
3372                     --ulen;     /* loop does extra increment */
3373                     s += ulen;
3374                     i += ulen;
3375                     continue;
3376                 }
3377             }
3378           not_utf8:
3379             odd++;
3380         }
3381         else if (*s < 32 &&
3382           *s != '\n' && *s != '\r' && *s != '\b' &&
3383           *s != '\t' && *s != '\f' && *s != 27)
3384             odd++;
3385 #endif
3386     }
3387
3388     if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3389         RETPUSHNO;
3390     else
3391         RETPUSHYES;
3392 }
3393
3394 /* File calls. */
3395
3396 PP(pp_chdir)
3397 {
3398     dVAR; dSP; dTARGET;
3399     const char *tmps = NULL;
3400     GV *gv = NULL;
3401
3402     if( MAXARG == 1 ) {
3403         SV * const sv = POPs;
3404         if (PL_op->op_flags & OPf_SPECIAL) {
3405             gv = gv_fetchsv(sv, 0, SVt_PVIO);
3406         }
3407         else if (isGV_with_GP(sv)) {
3408             gv = MUTABLE_GV(sv);
3409         }
3410         else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
3411             gv = MUTABLE_GV(SvRV(sv));
3412         }
3413         else {
3414             tmps = SvPV_nolen_const(sv);
3415         }
3416     }
3417
3418     if( !gv && (!tmps || !*tmps) ) {
3419         HV * const table = GvHVn(PL_envgv);
3420         SV **svp;
3421
3422         if (    (svp = hv_fetchs(table, "HOME", FALSE))
3423              || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3424 #ifdef VMS
3425              || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3426 #endif
3427            )
3428         {
3429             if( MAXARG == 1 )
3430                 deprecate("chdir('') or chdir(undef) as chdir()");
3431             tmps = SvPV_nolen_const(*svp);
3432         }
3433         else {
3434             PUSHi(0);
3435             TAINT_PROPER("chdir");
3436             RETURN;
3437         }
3438     }
3439
3440     TAINT_PROPER("chdir");
3441     if (gv) {
3442 #ifdef HAS_FCHDIR
3443         IO* const io = GvIO(gv);
3444         if (io) {
3445             if (IoDIRP(io)) {
3446                 PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3447             } else if (IoIFP(io)) {
3448                 PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3449             }
3450             else {
3451                 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3452                     report_evil_fh(gv, io, PL_op->op_type);
3453                 SETERRNO(EBADF, RMS_IFI);
3454                 PUSHi(0);
3455             }
3456         }
3457         else {
3458             if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
3459                 report_evil_fh(gv, io, PL_op->op_type);
3460             SETERRNO(EBADF,RMS_IFI);
3461             PUSHi(0);
3462         }
3463 #else
3464         DIE(aTHX_ PL_no_func, "fchdir");
3465 #endif
3466     }
3467     else 
3468         PUSHi( PerlDir_chdir(tmps) >= 0 );
3469 #ifdef VMS
3470     /* Clear the DEFAULT element of ENV so we'll get the new value
3471      * in the future. */
3472     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3473 #endif
3474     RETURN;
3475 }
3476
3477 PP(pp_chown)
3478 {
3479     dVAR; dSP; dMARK; dTARGET;
3480     const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3481
3482     SP = MARK;
3483     XPUSHi(value);
3484     RETURN;
3485 }
3486
3487 PP(pp_chroot)
3488 {
3489 #ifdef HAS_CHROOT
3490     dVAR; dSP; dTARGET;
3491     char * const tmps = POPpx;
3492     TAINT_PROPER("chroot");
3493     PUSHi( chroot(tmps) >= 0 );
3494     RETURN;
3495 #else
3496     DIE(aTHX_ PL_no_func, "chroot");
3497 #endif
3498 }
3499
3500 PP(pp_rename)
3501 {
3502     dVAR; dSP; dTARGET;
3503     int anum;
3504     const char * const tmps2 = POPpconstx;
3505     const char * const tmps = SvPV_nolen_const(TOPs);
3506     TAINT_PROPER("rename");
3507 #ifdef HAS_RENAME
3508     anum = PerlLIO_rename(tmps, tmps2);
3509 #else
3510     if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3511         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
3512             anum = 1;
3513         else {
3514             if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3515                 (void)UNLINK(tmps2);
3516             if (!(anum = link(tmps, tmps2)))
3517                 anum = UNLINK(tmps);
3518         }
3519     }
3520 #endif
3521     SETi( anum >= 0 );
3522     RETURN;
3523 }
3524
3525 #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3526 PP(pp_link)
3527 {
3528     dVAR; dSP; dTARGET;
3529     const int op_type = PL_op->op_type;
3530     int result;
3531
3532 #  ifndef HAS_LINK
3533     if (op_type == OP_LINK)
3534         DIE(aTHX_ PL_no_func, "link");
3535 #  endif
3536 #  ifndef HAS_SYMLINK
3537     if (op_type == OP_SYMLINK)
3538         DIE(aTHX_ PL_no_func, "symlink");
3539 #  endif
3540
3541     {
3542         const char * const tmps2 = POPpconstx;
3543         const char * const tmps = SvPV_nolen_const(TOPs);
3544         TAINT_PROPER(PL_op_desc[op_type]);
3545         result =
3546 #  if defined(HAS_LINK)
3547 #    if defined(HAS_SYMLINK)
3548             /* Both present - need to choose which.  */
3549             (op_type == OP_LINK) ?
3550             PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3551 #    else
3552     /* Only have link, so calls to pp_symlink will have DIE()d above.  */
3553         PerlLIO_link(tmps, tmps2);
3554 #    endif
3555 #  else
3556 #    if defined(HAS_SYMLINK)
3557     /* Only have symlink, so calls to pp_link will have DIE()d above.  */
3558         symlink(tmps, tmps2);
3559 #    endif
3560 #  endif
3561     }
3562
3563     SETi( result >= 0 );
3564     RETURN;
3565 }
3566 #else
3567 PP(pp_link)
3568 {
3569     /* Have neither.  */
3570     DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3571 }
3572 #endif
3573
3574 PP(pp_readlink)
3575 {
3576     dVAR;
3577     dSP;
3578 #ifdef HAS_SYMLINK
3579     dTARGET;
3580     const char *tmps;
3581     char buf[MAXPATHLEN];
3582     int len;
3583
3584 #ifndef INCOMPLETE_TAINTS
3585     TAINT;
3586 #endif
3587     tmps = POPpconstx;
3588     len = readlink(tmps, buf, sizeof(buf) - 1);
3589     EXTEND(SP, 1);
3590     if (len < 0)
3591         RETPUSHUNDEF;
3592     PUSHp(buf, len);
3593     RETURN;
3594 #else
3595     EXTEND(SP, 1);
3596     RETSETUNDEF;                /* just pretend it's a normal file */
3597 #endif
3598 }
3599
3600 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3601 STATIC int
3602 S_dooneliner(pTHX_ const char *cmd, const char *filename)
3603 {
3604     char * const save_filename = filename;
3605     char *cmdline;
3606     char *s;
3607     PerlIO *myfp;
3608     int anum = 1;
3609     Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3610
3611     PERL_ARGS_ASSERT_DOONELINER;
3612
3613     Newx(cmdline, size, char);
3614     my_strlcpy(cmdline, cmd, size);
3615     my_strlcat(cmdline, " ", size);
3616     for (s = cmdline + strlen(cmdline); *filename; ) {
3617         *s++ = '\\';
3618         *s++ = *filename++;
3619     }
3620     if (s - cmdline < size)
3621         my_strlcpy(s, " 2>&1", size - (s - cmdline));
3622     myfp = PerlProc_popen(cmdline, "r");
3623     Safefree(cmdline);
3624
3625     if (myfp) {
3626         SV * const tmpsv = sv_newmortal();
3627         /* Need to save/restore 'PL_rs' ?? */
3628         s = sv_gets(tmpsv, myfp, 0);
3629         (void)PerlProc_pclose(myfp);
3630         if (s != NULL) {
3631             int e;
3632             for (e = 1;
3633 #ifdef HAS_SYS_ERRLIST
3634                  e <= sys_nerr
3635 #endif
3636                  ; e++)
3637             {
3638                 /* you don't see this */
3639                 const char * const errmsg =
3640 #ifdef HAS_SYS_ERRLIST
3641                     sys_errlist[e]
3642 #else
3643                     strerror(e)
3644 #endif
3645                     ;
3646                 if (!errmsg)
3647                     break;
3648                 if (instr(s, errmsg)) {
3649                     SETERRNO(e,0);
3650                     return 0;
3651                 }
3652             }
3653             SETERRNO(0,0);
3654 #ifndef EACCES
3655 #define EACCES EPERM
3656 #endif
3657             if (instr(s, "cannot make"))
3658                 SETERRNO(EEXIST,RMS_FEX);
3659             else if (instr(s, "existing file"))
3660                 SETERRNO(EEXIST,RMS_FEX);
3661             else if (instr(s, "ile exists"))
3662                 SETERRNO(EEXIST,RMS_FEX);
3663             else if (instr(s, "non-exist"))
3664                 SETERRNO(ENOENT,RMS_FNF);
3665             else if (instr(s, "does not exist"))
3666                 SETERRNO(ENOENT,RMS_FNF);
3667             else if (instr(s, "not empty"))
3668                 SETERRNO(EBUSY,SS_DEVOFFLINE);
3669             else if (instr(s, "cannot access"))
3670                 SETERRNO(EACCES,RMS_PRV);
3671             else
3672                 SETERRNO(EPERM,RMS_PRV);
3673             return 0;
3674         }
3675         else {  /* some mkdirs return no failure indication */
3676             anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3677             if (PL_op->op_type == OP_RMDIR)
3678                 anum = !anum;
3679             if (anum)
3680                 SETERRNO(0,0);
3681             else
3682                 SETERRNO(EACCES,RMS_PRV);       /* a guess */
3683         }
3684         return anum;
3685     }
3686     else
3687         return 0;
3688 }
3689 #endif
3690
3691 /* This macro removes trailing slashes from a directory name.
3692  * Different operating and file systems take differently to
3693  * trailing slashes.  According to POSIX 1003.1 1996 Edition
3694  * any number of trailing slashes should be allowed.
3695  * Thusly we snip them away so that even non-conforming
3696  * systems are happy.
3697  * We should probably do this "filtering" for all
3698  * the functions that expect (potentially) directory names:
3699  * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3700  * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3701
3702 #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3703     if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3704         do { \
3705             (len)--; \
3706         } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3707         (tmps) = savepvn((tmps), (len)); \
3708         (copy) = TRUE; \
3709     }
3710
3711 PP(pp_mkdir)
3712 {
3713     dVAR; dSP; dTARGET;
3714     STRLEN len;
3715     const char *tmps;
3716     bool copy = FALSE;
3717     const int mode = (MAXARG > 1) ? POPi : 0777;
3718
3719     TRIMSLASHES(tmps,len,copy);
3720
3721     TAINT_PROPER("mkdir");
3722 #ifdef HAS_MKDIR
3723     SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3724 #else
3725     {
3726     int oldumask;
3727     SETi( dooneliner("mkdir", tmps) );
3728     oldumask = PerlLIO_umask(0);
3729     PerlLIO_umask(oldumask);
3730     PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3731     }
3732 #endif
3733     if (copy)
3734         Safefree(tmps);
3735     RETURN;
3736 }
3737
3738 PP(pp_rmdir)
3739 {
3740     dVAR; dSP; dTARGET;
3741     STRLEN len;
3742     const char *tmps;
3743     bool copy = FALSE;
3744
3745     TRIMSLASHES(tmps,len,copy);
3746     TAINT_PROPER("rmdir");
3747 #ifdef HAS_RMDIR
3748     SETi( PerlDir_rmdir(tmps) >= 0 );
3749 #else
3750     SETi( dooneliner("rmdir", tmps) );
3751 #endif
3752     if (copy)
3753         Safefree(tmps);
3754     RETURN;
3755 }
3756
3757 /* Directory calls. */
3758
3759 PP(pp_open_dir)
3760 {
3761 #if defined(Direntry_t) && defined(HAS_READDIR)
3762     dVAR; dSP;
3763     const char * const dirname = POPpconstx;
3764     GV * const gv = MUTABLE_GV(POPs);
3765     register IO * const io = GvIOn(gv);
3766
3767     if (!io)
3768         goto nope;
3769
3770     if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED))
3771         Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3772                 "Opening filehandle %s also as a directory", GvENAME(gv));
3773     if (IoDIRP(io))
3774         PerlDir_close(IoDIRP(io));
3775     if (!(IoDIRP(io) = PerlDir_open(dirname)))
3776         goto nope;
3777
3778     RETPUSHYES;
3779 nope:
3780     if (!errno)
3781         SETERRNO(EBADF,RMS_DIR);
3782     RETPUSHUNDEF;
3783 #else
3784     DIE(aTHX_ PL_no_dir_func, "opendir");
3785 #endif
3786 }
3787
3788 PP(pp_readdir)
3789 {
3790 #if !defined(Direntry_t) || !defined(HAS_READDIR)
3791     DIE(aTHX_ PL_no_dir_func, "readdir");
3792 #else
3793 #if !defined(I_DIRENT) && !defined(VMS)
3794     Direntry_t *readdir (DIR *);
3795 #endif
3796     dVAR;
3797     dSP;
3798
3799     SV *sv;
3800     const I32 gimme = GIMME;
3801     GV * const gv = MUTABLE_GV(POPs);
3802     register const Direntry_t *dp;
3803     register IO * const io = GvIOn(gv);
3804
3805     if (!io || !IoDIRP(io)) {
3806         if(ckWARN(WARN_IO)) {
3807             Perl_warner(aTHX_ packWARN(WARN_IO),
3808                 "readdir() attempted on invalid dirhandle %s", GvENAME(gv));
3809         }
3810         goto nope;
3811     }
3812
3813     do {
3814         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3815         if (!dp)
3816             break;
3817 #ifdef DIRNAMLEN
3818         sv = newSVpvn(dp->d_name, dp->d_namlen);
3819 #else
3820         sv = newSVpv(dp->d_name, 0);
3821 #endif
3822 #ifndef INCOMPLETE_TAINTS
3823         if (!(IoFLAGS(io) & IOf_UNTAINT))
3824             SvTAINTED_on(sv);
3825 #endif
3826         mXPUSHs(sv);
3827     } while (gimme == G_ARRAY);
3828
3829     if (!dp && gimme != G_ARRAY)
3830         goto nope;
3831
3832     RETURN;
3833
3834 nope:
3835     if (!errno)
3836         SETERRNO(EBADF,RMS_ISI);
3837     if (GIMME == G_ARRAY)
3838         RETURN;
3839     else
3840         RETPUSHUNDEF;
3841 #endif
3842 }
3843
3844 PP(pp_telldir)
3845 {
3846 #if defined(HAS_TELLDIR) || defined(telldir)
3847     dVAR; dSP; dTARGET;
3848  /* XXX does _anyone_ need this? --AD 2/20/1998 */
3849  /* XXX netbsd still seemed to.
3850     XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3851     --JHI 1999-Feb-02 */
3852 # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3853     long telldir (DIR *);
3854 # endif
3855     GV * const gv = MUTABLE_GV(POPs);
3856     register IO * const io = GvIOn(gv);
3857
3858     if (!io || !IoDIRP(io)) {
3859         if(ckWARN(WARN_IO)) {
3860             Perl_warner(aTHX_ packWARN(WARN_IO),
3861                 "telldir() attempted on invalid dirhandle %s", GvENAME(gv));
3862         }
3863         goto nope;
3864     }
3865
3866     PUSHi( PerlDir_tell(IoDIRP(io)) );
3867     RETURN;
3868 nope:
3869     if (!errno)
3870         SETERRNO(EBADF,RMS_ISI);
3871     RETPUSHUNDEF;
3872 #else
3873     DIE(aTHX_ PL_no_dir_func, "telldir");
3874 #endif
3875 }
3876
3877 PP(pp_seekdir)
3878 {
3879 #if defined(HAS_SEEKDIR) || defined(seekdir)
3880     dVAR; dSP;
3881     const long along = POPl;
3882     GV * const gv = MUTABLE_GV(POPs);
3883     register IO * const io = GvIOn(gv);
3884
3885     if (!io || !IoDIRP(io)) {
3886         if(ckWARN(WARN_IO)) {
3887             Perl_warner(aTHX_ packWARN(WARN_IO),
3888                 "seekdir() attempted on invalid dirhandle %s", GvENAME(gv));
3889         }
3890         goto nope;
3891     }
3892     (void)PerlDir_seek(IoDIRP(io), along);
3893
3894     RETPUSHYES;
3895 nope:
3896     if (!errno)
3897         SETERRNO(EBADF,RMS_ISI);
3898     RETPUSHUNDEF;
3899 #else
3900     DIE(aTHX_ PL_no_dir_func, "seekdir");
3901 #endif
3902 }
3903
3904 PP(pp_rewinddir)
3905 {
3906 #if defined(HAS_REWINDDIR) || defined(rewinddir)
3907     dVAR; dSP;
3908     GV * const gv = MUTABLE_GV(POPs);
3909     register IO * const io = GvIOn(gv);
3910
3911     if (!io || !IoDIRP(io)) {
3912         if(ckWARN(WARN_IO)) {
3913             Perl_warner(aTHX_ packWARN(WARN_IO),
3914                 "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv));
3915         }
3916         goto nope;
3917     }
3918     (void)PerlDir_rewind(IoDIRP(io));
3919     RETPUSHYES;
3920 nope:
3921     if (!errno)
3922         SETERRNO(EBADF,RMS_ISI);
3923     RETPUSHUNDEF;
3924 #else
3925     DIE(aTHX_ PL_no_dir_func, "rewinddir");
3926 #endif
3927 }
3928
3929 PP(pp_closedir)
3930 {
3931 #if defined(Direntry_t) && defined(HAS_READDIR)
3932     dVAR; dSP;
3933     GV * const gv = MUTABLE_GV(POPs);
3934     register IO * const io = GvIOn(gv);
3935
3936     if (!io || !IoDIRP(io)) {
3937         if(ckWARN(WARN_IO)) {
3938             Perl_warner(aTHX_ packWARN(WARN_IO),
3939                 "closedir() attempted on invalid dirhandle %s", GvENAME(gv));
3940         }
3941         goto nope;
3942     }
3943 #ifdef VOID_CLOSEDIR
3944     PerlDir_close(IoDIRP(io));
3945 #else
3946     if (PerlDir_close(IoDIRP(io)) < 0) {
3947         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3948         goto nope;
3949     }
3950 #endif
3951     IoDIRP(io) = 0;
3952
3953     RETPUSHYES;
3954 nope:
3955     if (!errno)
3956         SETERRNO(EBADF,RMS_IFI);
3957     RETPUSHUNDEF;
3958 #else
3959     DIE(aTHX_ PL_no_dir_func, "closedir");
3960 #endif
3961 }
3962
3963 /* Process control. */
3964
3965 PP(pp_fork)
3966 {
3967 #ifdef HAS_FORK
3968     dVAR; dSP; dTARGET;
3969     Pid_t childpid;
3970
3971     EXTEND(SP, 1);
3972     PERL_FLUSHALL_FOR_CHILD;
3973     childpid = PerlProc_fork();
3974     if (childpid < 0)
3975         RETSETUNDEF;
3976     if (!childpid) {
3977         GV * const tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV);
3978         if (tmpgv) {
3979             SvREADONLY_off(GvSV(tmpgv));
3980             sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3981             SvREADONLY_on(GvSV(tmpgv));
3982         }
3983 #ifdef THREADS_HAVE_PIDS
3984         PL_ppid = (IV)getppid();
3985 #endif
3986 #ifdef PERL_USES_PL_PIDSTATUS
3987         hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
3988 #endif
3989     }
3990     PUSHi(childpid);
3991     RETURN;
3992 #else
3993 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3994     dSP; dTARGET;
3995     Pid_t childpid;
3996
3997     EXTEND(SP, 1);
3998     PERL_FLUSHALL_FOR_CHILD;
3999     childpid = PerlProc_fork();
4000     if (childpid == -1)
4001         RETSETUNDEF;
4002     PUSHi(childpid);
4003     RETURN;
4004 #  else
4005     DIE(aTHX_ PL_no_func, "fork");
4006 #  endif
4007 #endif
4008 }
4009
4010 PP(pp_wait)
4011 {
4012 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4013     dVAR; dSP; dTARGET;
4014     Pid_t childpid;
4015     int argflags;
4016
4017     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4018         childpid = wait4pid(-1, &argflags, 0);
4019     else {
4020         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4021                errno == EINTR) {
4022           PERL_ASYNC_CHECK();
4023         }
4024     }
4025 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4026     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4027     STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4028 #  else
4029     STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
4030 #  endif
4031     XPUSHi(childpid);
4032     RETURN;
4033 #else
4034     DIE(aTHX_ PL_no_func, "wait");
4035 #endif
4036 }
4037
4038 PP(pp_waitpid)
4039 {
4040 #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__)
4041     dVAR; dSP; dTARGET;
4042     const int optype = POPi;
4043     const Pid_t pid = TOPi;
4044     Pid_t result;
4045     int argflags;
4046
4047     if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4048         result = wait4pid(pid, &argflags, optype);
4049     else {
4050         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4051                errno == EINTR) {
4052           PERL_ASYNC_CHECK();
4053         }
4054     }
4055 #  if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4056     /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4057     STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4058 #  else
4059     STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
4060 #  endif
4061     SETi(result);
4062     RETURN;
4063 #else
4064     DIE(aTHX_ PL_no_func, "waitpid");
4065 #endif
4066 }
4067
4068 PP(pp_system)
4069 {
4070     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4071 #if defined(__LIBCATAMOUNT__)
4072     PL_statusvalue = -1;
4073     SP = ORIGMARK;
4074     XPUSHi(-1);
4075 #else
4076     I32 value;
4077     int result;
4078
4079     if (PL_tainting) {
4080         TAINT_ENV();
4081         while (++MARK <= SP) {
4082             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4083             if (PL_tainted)
4084                 break;
4085         }
4086         MARK = ORIGMARK;
4087         TAINT_PROPER("system");
4088     }
4089     PERL_FLUSHALL_FOR_CHILD;
4090 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4091     {
4092         Pid_t childpid;
4093         int pp[2];
4094         I32 did_pipes = 0;
4095
4096         if (PerlProc_pipe(pp) >= 0)
4097             did_pipes = 1;
4098         while ((childpid = PerlProc_fork()) == -1) {
4099             if (errno != EAGAIN) {
4100                 value = -1;
4101                 SP = ORIGMARK;
4102                 XPUSHi(value);
4103                 if (did_pipes) {
4104                     PerlLIO_close(pp[0]);
4105                     PerlLIO_close(pp[1]);
4106                 }
4107                 RETURN;
4108             }
4109             sleep(5);
4110         }
4111         if (childpid > 0) {
4112             Sigsave_t ihand,qhand; /* place to save signals during system() */
4113             int status;
4114
4115             if (did_pipes)
4116                 PerlLIO_close(pp[1]);
4117 #ifndef PERL_MICRO
4118             rsignal_save(SIGINT,  (Sighandler_t) SIG_IGN, &ihand);
4119             rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand);
4120 #endif
4121             do {
4122                 result = wait4pid(childpid, &status, 0);
4123             } while (result == -1 && errno == EINTR);
4124 #ifndef PERL_MICRO
4125             (void)rsignal_restore(SIGINT, &ihand);
4126             (void)rsignal_restore(SIGQUIT, &qhand);
4127 #endif
4128             STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status);
4129             do_execfree();      /* free any memory child malloced on fork */
4130             SP = ORIGMARK;
4131             if (did_pipes) {
4132                 int errkid;
4133                 unsigned n = 0;
4134                 SSize_t n1;
4135
4136                 while (n < sizeof(int)) {
4137                     n1 = PerlLIO_read(pp[0],
4138                                       (void*)(((char*)&errkid)+n),
4139                                       (sizeof(int)) - n);
4140                     if (n1 <= 0)
4141                         break;
4142                     n += n1;
4143                 }
4144                 PerlLIO_close(pp[0]);
4145                 if (n) {                        /* Error */
4146                     if (n != sizeof(int))
4147                         DIE(aTHX_ "panic: kid popen errno read");
4148                     errno = errkid;             /* Propagate errno from kid */
4149                     STATUS_NATIVE_CHILD_SET(-1);
4150                 }
4151             }
4152             XPUSHi(STATUS_CURRENT);
4153             RETURN;
4154         }
4155         if (did_pipes) {
4156             PerlLIO_close(pp[0]);
4157 #if defined(HAS_FCNTL) && defined(F_SETFD)
4158             fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4159 #endif
4160         }
4161         if (PL_op->op_flags & OPf_STACKED) {
4162             SV * const really = *++MARK;
4163             value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
4164         }
4165         else if (SP - MARK != 1)
4166             value = (I32)do_aexec5(NULL, MARK, SP, pp[1], did_pipes);
4167         else {
4168             value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes);
4169         }
4170         PerlProc__exit(-1);
4171     }
4172 #else /* ! FORK or VMS or OS/2 */
4173     PL_statusvalue = 0;
4174     result = 0;
4175     if (PL_op->op_flags & OPf_STACKED) {
4176         SV * const really = *++MARK;
4177 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4178         value = (I32)do_aspawn(really, MARK, SP);
4179 #  else
4180         value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
4181 #  endif
4182     }
4183     else if (SP - MARK != 1) {
4184 #  if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__)
4185         value = (I32)do_aspawn(NULL, MARK, SP);
4186 #  else
4187         value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP);
4188 #  endif
4189     }
4190     else {
4191         value = (I32)do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4192     }
4193     if (PL_statusvalue == -1)   /* hint that value must be returned as is */
4194         result = 1;
4195     STATUS_NATIVE_CHILD_SET(value);
4196     do_execfree();
4197     SP = ORIGMARK;
4198     XPUSHi(result ? value : STATUS_CURRENT);
4199 #endif /* !FORK or VMS or OS/2 */
4200 #endif
4201     RETURN;
4202 }
4203
4204 PP(pp_exec)
4205 {
4206     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4207     I32 value;
4208
4209     if (PL_tainting) {
4210         TAINT_ENV();
4211         while (++MARK <= SP) {
4212             (void)SvPV_nolen_const(*MARK);      /* stringify for taint check */
4213             if (PL_tainted)
4214                 break;
4215         }
4216         MARK = ORIGMARK;
4217         TAINT_PROPER("exec");
4218     }
4219     PERL_FLUSHALL_FOR_CHILD;
4220     if (PL_op->op_flags & OPf_STACKED) {
4221         SV * const really = *++MARK;
4222         value = (I32)do_aexec(really, MARK, SP);
4223     }
4224     else if (SP - MARK != 1)
4225 #ifdef VMS
4226         value = (I32)vms_do_aexec(NULL, MARK, SP);
4227 #else
4228 #  ifdef __OPEN_VM
4229         {
4230            (void ) do_aspawn(NULL, MARK, SP);
4231            value = 0;
4232         }
4233 #  else
4234         value = (I32)do_aexec(NULL, MARK, SP);
4235 #  endif
4236 #endif
4237     else {
4238 #ifdef VMS
4239         value = (I32)vms_do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4240 #else
4241 #  ifdef __OPEN_VM
4242         (void) do_spawn(SvPVx_nolen(sv_mortalcopy(*SP)));
4243         value = 0;
4244 #  else
4245         value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP)));
4246 #  endif
4247 #endif
4248     }
4249
4250     SP = ORIGMARK;
4251     XPUSHi(value);
4252     RETURN;
4253 }
4254
4255 PP(pp_getppid)
4256 {
4257 #ifdef HAS_GETPPID
4258     dVAR; dSP; dTARGET;
4259 #   ifdef THREADS_HAVE_PIDS
4260     if (PL_ppid != 1 && getppid() == 1)
4261         /* maybe the parent process has died. Refresh ppid cache */
4262         PL_ppid = 1;
4263     XPUSHi( PL_ppid );
4264 #   else
4265     XPUSHi( getppid() );
4266 #   endif
4267     RETURN;
4268 #else
4269     DIE(aTHX_ PL_no_func, "getppid");
4270 #endif
4271 }
4272
4273 PP(pp_getpgrp)
4274 {
4275 #ifdef HAS_GETPGRP
4276     dVAR; dSP; dTARGET;
4277     Pid_t pgrp;
4278     const Pid_t pid = (MAXARG < 1) ? 0 : SvIVx(POPs);
4279
4280 #ifdef BSD_GETPGRP
4281     pgrp = (I32)BSD_GETPGRP(pid);
4282 #else
4283     if (pid != 0 && pid != PerlProc_getpid())
4284         DIE(aTHX_ "POSIX getpgrp can't take an argument");
4285     pgrp = getpgrp();
4286 #endif
4287     XPUSHi(pgrp);
4288     RETURN;
4289 #else
4290     DIE(aTHX_ PL_no_func, "getpgrp()");
4291 #endif
4292 }
4293
4294 PP(pp_setpgrp)
4295 {
4296 #ifdef HAS_SETPGRP
4297     dVAR; dSP; dTARGET;
4298     Pid_t pgrp;
4299     Pid_t pid;
4300     if (MAXARG < 2) {
4301         pgrp = 0;
4302         pid = 0;
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 #&nbs