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