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