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