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