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