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