This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
caa5e379f0c314ec2942ef2acc80b40029977368
[perl5.git] / pp_sys.c
1 /*    pp_sys.c
2  *
3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
19
20 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
21 #ifdef I_UNISTD
22 # include <unistd.h>
23 #endif
24
25 #ifdef HAS_SYSCALL   
26 #ifdef __cplusplus              
27 extern "C" int syscall(unsigned long,...);
28 #endif
29 #endif
30
31 #ifdef I_SYS_WAIT
32 # include <sys/wait.h>
33 #endif
34
35 #ifdef I_SYS_RESOURCE
36 # include <sys/resource.h>
37 #endif
38
39 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
40 # include <sys/socket.h>
41 # include <netdb.h>
42 # ifndef ENOTSOCK
43 #  ifdef I_NET_ERRNO
44 #   include <net/errno.h>
45 #  endif
46 # endif
47 #endif
48
49 #ifdef HAS_SELECT
50 #ifdef I_SYS_SELECT
51 #include <sys/select.h>
52 #endif
53 #endif
54
55 #ifdef HOST_NOT_FOUND
56 extern int h_errno;
57 #endif
58
59 #ifdef HAS_PASSWD
60 # ifdef I_PWD
61 #  include <pwd.h>
62 # else
63     struct passwd *getpwnam _((char *));
64     struct passwd *getpwuid _((Uid_t));
65 # endif
66   struct passwd *getpwent _((void));
67 #endif
68
69 #ifdef HAS_GROUP
70 # ifdef I_GRP
71 #  include <grp.h>
72 # else
73     struct group *getgrnam _((char *));
74     struct group *getgrgid _((Gid_t));
75 # endif
76     struct group *getgrent _((void));
77 #endif
78
79 #ifdef I_UTIME
80 #  ifdef _MSC_VER
81 #    include <sys/utime.h>
82 #  else
83 #    include <utime.h>
84 #  endif
85 #endif
86 #ifdef I_FCNTL
87 #include <fcntl.h>
88 #endif
89 #ifdef I_SYS_FILE
90 #include <sys/file.h>
91 #endif
92
93 /* Put this after #includes because fork and vfork prototypes may conflict. */
94 #ifndef HAS_VFORK
95 #   define vfork fork
96 #endif
97
98 /* Put this after #includes because <unistd.h> defines _XOPEN_*. */
99 #ifndef Sock_size_t
100 #  if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
101 #    define Sock_size_t Size_t
102 #  else
103 #    define Sock_size_t int
104 #  endif
105 #endif
106
107 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
108 static int dooneliner _((char *cmd, char *filename));
109 #endif
110
111 #ifdef HAS_CHSIZE
112 # ifdef my_chsize  /* Probably #defined to Perl_my_chsize in embed.h */
113 #   undef my_chsize
114 # endif
115 # define my_chsize chsize
116 #endif
117
118 #ifdef HAS_FLOCK
119 #  define FLOCK flock
120 #else /* no flock() */
121
122    /* fcntl.h might not have been included, even if it exists, because
123       the current Configure only sets I_FCNTL if it's needed to pick up
124       the *_OK constants.  Make sure it has been included before testing
125       the fcntl() locking constants. */
126 #  if defined(HAS_FCNTL) && !defined(I_FCNTL)
127 #    include <fcntl.h>
128 #  endif
129
130 #  if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
131 #    define FLOCK fcntl_emulate_flock
132 #    define FCNTL_EMULATE_FLOCK
133 #  else /* no flock() or fcntl(F_SETLK,...) */
134 #    ifdef HAS_LOCKF
135 #      define FLOCK lockf_emulate_flock
136 #      define LOCKF_EMULATE_FLOCK
137 #    endif /* lockf */
138 #  endif /* no flock() or fcntl(F_SETLK,...) */
139
140 #  ifdef FLOCK
141      static int FLOCK _((int, int));
142
143     /*
144      * These are the flock() constants.  Since this sytems doesn't have
145      * flock(), the values of the constants are probably not available.
146      */
147 #    ifndef LOCK_SH
148 #      define LOCK_SH 1
149 #    endif
150 #    ifndef LOCK_EX
151 #      define LOCK_EX 2
152 #    endif
153 #    ifndef LOCK_NB
154 #      define LOCK_NB 4
155 #    endif
156 #    ifndef LOCK_UN
157 #      define LOCK_UN 8
158 #    endif
159 #  endif /* emulating flock() */
160
161 #endif /* no flock() */
162
163 #ifndef MAXPATHLEN
164 #  ifdef PATH_MAX
165 #    define MAXPATHLEN PATH_MAX
166 #  else
167 #    define MAXPATHLEN 1024
168 #  endif
169 #endif
170
171 #define ZBTLEN 10
172 static char zero_but_true[ZBTLEN + 1] = "0 but true";
173
174 /* Pushy I/O. */
175
176 PP(pp_backtick)
177 {
178     dSP; dTARGET;
179     PerlIO *fp;
180     char *tmps = POPp;
181     I32 gimme = GIMME_V;
182
183     TAINT_PROPER("``");
184     fp = my_popen(tmps, "r");
185     if (fp) {
186         if (gimme == G_VOID) {
187             char tmpbuf[256];
188             while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
189                 /*SUPPRESS 530*/
190                 ;
191         }
192         else if (gimme == G_SCALAR) {
193             sv_setpv(TARG, ""); /* note that this preserves previous buffer */
194             while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
195                 /*SUPPRESS 530*/
196                 ;
197             XPUSHs(TARG);
198             SvTAINTED_on(TARG);
199         }
200         else {
201             SV *sv;
202
203             for (;;) {
204                 sv = NEWSV(56, 80);
205                 if (sv_gets(sv, fp, 0) == Nullch) {
206                     SvREFCNT_dec(sv);
207                     break;
208                 }
209                 XPUSHs(sv_2mortal(sv));
210                 if (SvLEN(sv) - SvCUR(sv) > 20) {
211                     SvLEN_set(sv, SvCUR(sv)+1);
212                     Renew(SvPVX(sv), SvLEN(sv), char);
213                 }
214                 SvTAINTED_on(sv);
215             }
216         }
217         STATUS_NATIVE_SET(my_pclose(fp));
218         TAINT;          /* "I believe that this is not gratuitous!" */
219     }
220     else {
221         STATUS_NATIVE_SET(-1);
222         if (gimme == G_SCALAR)
223             RETPUSHUNDEF;
224     }
225
226     RETURN;
227 }
228
229 PP(pp_glob)
230 {
231     OP *result;
232     ENTER;
233
234 #ifndef VMS
235     if (tainting) {
236         /*
237          * The external globbing program may use things we can't control,
238          * so for security reasons we must assume the worst.
239          */
240         TAINT;
241         taint_proper(no_security, "glob");
242     }
243 #endif /* !VMS */
244
245     SAVESPTR(last_in_gv);       /* We don't want this to be permanent. */
246     last_in_gv = (GV*)*stack_sp--;
247
248     SAVESPTR(rs);               /* This is not permanent, either. */
249     rs = sv_2mortal(newSVpv("", 1));
250 #ifndef DOSISH
251 #ifndef CSH
252     *SvPVX(rs) = '\n';
253 #endif  /* !CSH */
254 #endif  /* !DOSISH */
255
256     result = do_readline();
257     LEAVE;
258     return result;
259 }
260
261 PP(pp_indread)
262 {
263     last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*stack_sp--)), na), TRUE,SVt_PVIO);
264     return do_readline();
265 }
266
267 PP(pp_rcatline)
268 {
269     last_in_gv = cGVOP->op_gv;
270     return do_readline();
271 }
272
273 PP(pp_warn)
274 {
275     dSP; dMARK;
276     char *tmps;
277     if (SP - MARK != 1) {
278         dTARGET;
279         do_join(TARG, &sv_no, MARK, SP);
280         tmps = SvPV(TARG, na);
281         SP = MARK + 1;
282     }
283     else {
284         tmps = SvPV(TOPs, na);
285     }
286     if (!tmps || !*tmps) {
287         (void)SvUPGRADE(errsv, SVt_PV);
288         if (SvPOK(errsv) && SvCUR(errsv))
289             sv_catpv(errsv, "\t...caught");
290         tmps = SvPV(errsv, na);
291     }
292     if (!tmps || !*tmps)
293         tmps = "Warning: something's wrong";
294     warn("%s", tmps);
295     RETSETYES;
296 }
297
298 PP(pp_die)
299 {
300     dSP; dMARK;
301     char *tmps;
302     if (SP - MARK != 1) {
303         dTARGET;
304         do_join(TARG, &sv_no, MARK, SP);
305         tmps = SvPV(TARG, na);
306         SP = MARK + 1;
307     }
308     else {
309         tmps = SvPV(TOPs, na);
310     }
311     if (!tmps || !*tmps) {
312         (void)SvUPGRADE(errsv, SVt_PV);
313         if (SvPOK(errsv) && SvCUR(errsv))
314             sv_catpv(errsv, "\t...propagated");
315         tmps = SvPV(errsv, na);
316     }
317     if (!tmps || !*tmps)
318         tmps = "Died";
319     DIE("%s", tmps);
320 }
321
322 /* I/O. */
323
324 PP(pp_open)
325 {
326     dSP; dTARGET;
327     GV *gv;
328     SV *sv;
329     char *tmps;
330     STRLEN len;
331
332     if (MAXARG > 1)
333         sv = POPs;
334     if (!isGV(TOPs))
335         DIE(no_usym, "filehandle");
336     if (MAXARG <= 1)
337         sv = GvSV(TOPs);
338     gv = (GV*)POPs;
339     if (!isGV(gv))
340         DIE(no_usym, "filehandle");
341     if (GvIOp(gv))
342         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
343     tmps = SvPV(sv, len);
344     if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
345         PUSHi( (I32)forkprocess );
346     else if (forkprocess == 0)          /* we are a new child */
347         PUSHi(0);
348     else
349         RETPUSHUNDEF;
350     RETURN;
351 }
352
353 PP(pp_close)
354 {
355     dSP;
356     GV *gv;
357
358     if (MAXARG == 0)
359         gv = defoutgv;
360     else
361         gv = (GV*)POPs;
362     EXTEND(SP, 1);
363     PUSHs(boolSV(do_close(gv, TRUE)));
364     RETURN;
365 }
366
367 PP(pp_pipe_op)
368 {
369     dSP;
370 #ifdef HAS_PIPE
371     GV *rgv;
372     GV *wgv;
373     register IO *rstio;
374     register IO *wstio;
375     int fd[2];
376
377     wgv = (GV*)POPs;
378     rgv = (GV*)POPs;
379
380     if (!rgv || !wgv)
381         goto badexit;
382
383     if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
384         DIE(no_usym, "filehandle");
385     rstio = GvIOn(rgv);
386     wstio = GvIOn(wgv);
387
388     if (IoIFP(rstio))
389         do_close(rgv, FALSE);
390     if (IoIFP(wstio))
391         do_close(wgv, FALSE);
392
393     if (pipe(fd) < 0)
394         goto badexit;
395
396     IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
397     IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
398     IoIFP(wstio) = IoOFP(wstio);
399     IoTYPE(rstio) = '<';
400     IoTYPE(wstio) = '>';
401
402     if (!IoIFP(rstio) || !IoOFP(wstio)) {
403         if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
404         else close(fd[0]);
405         if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
406         else close(fd[1]);
407         goto badexit;
408     }
409
410     RETPUSHYES;
411
412 badexit:
413     RETPUSHUNDEF;
414 #else
415     DIE(no_func, "pipe");
416 #endif
417 }
418
419 PP(pp_fileno)
420 {
421     dSP; dTARGET;
422     GV *gv;
423     IO *io;
424     PerlIO *fp;
425     if (MAXARG < 1)
426         RETPUSHUNDEF;
427     gv = (GV*)POPs;
428     if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
429         RETPUSHUNDEF;
430     PUSHi(PerlIO_fileno(fp));
431     RETURN;
432 }
433
434 PP(pp_umask)
435 {
436     dSP; dTARGET;
437     int anum;
438
439 #ifdef HAS_UMASK
440     if (MAXARG < 1) {
441         anum = umask(0);
442         (void)umask(anum);
443     }
444     else
445         anum = umask(POPi);
446     TAINT_PROPER("umask");
447     XPUSHi(anum);
448 #else
449     DIE(no_func, "Unsupported function umask");
450 #endif
451     RETURN;
452 }
453
454 PP(pp_binmode)
455 {
456     dSP;
457     GV *gv;
458     IO *io;
459     PerlIO *fp;
460
461     if (MAXARG < 1)
462         RETPUSHUNDEF;
463
464     gv = (GV*)POPs;
465
466     EXTEND(SP, 1);
467     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
468         RETPUSHUNDEF;
469
470 #ifdef DOSISH
471 #ifdef atarist
472     if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
473         RETPUSHYES;
474     else
475         RETPUSHUNDEF;
476 #else
477     if (setmode(PerlIO_fileno(fp), OP_BINARY) != -1) {
478 #if defined(WIN32) && defined(__BORLANDC__)
479         /* The translation mode of the stream is maintained independent
480          * of the translation mode of the fd in the Borland RTL (heavy
481          * digging through their runtime sources reveal).  User has to
482          * set the mode explicitly for the stream (though they don't
483          * document this anywhere). GSAR 97-5-24
484          */
485         PerlIO_seek(fp,0L,0);
486         fp->flags |= _F_BIN;
487 #endif
488         RETPUSHYES;
489     }
490     else
491         RETPUSHUNDEF;
492 #endif
493 #else
494 #if defined(USEMYBINMODE)
495     if (my_binmode(fp,IoTYPE(io)) != NULL)
496         RETPUSHYES;
497         else
498         RETPUSHUNDEF;
499 #else
500     RETPUSHYES;
501 #endif
502 #endif
503
504 }
505
506 PP(pp_tie)
507 {
508     dSP;
509     SV *varsv;
510     HV* stash;
511     GV *gv;
512     BINOP myop;
513     SV *sv;
514     SV **mark = stack_base + ++*markstack_ptr;  /* reuse in entersub */
515     I32 markoff = mark - stack_base - 1;
516     char *methname;
517     bool oldcatch = CATCH_GET;
518
519     varsv = mark[0];
520     if (SvTYPE(varsv) == SVt_PVHV)
521         methname = "TIEHASH";
522     else if (SvTYPE(varsv) == SVt_PVAV)
523         methname = "TIEARRAY";
524     else if (SvTYPE(varsv) == SVt_PVGV)
525         methname = "TIEHANDLE";
526     else
527         methname = "TIESCALAR";
528
529     stash = gv_stashsv(mark[1], FALSE);
530     if (!stash || !(gv = gv_fetchmethod(stash, methname)))
531         DIE("Can't locate object method \"%s\" via package \"%s\"",
532                 methname, SvPV(mark[1],na));
533
534     Zero(&myop, 1, BINOP);
535     myop.op_last = (OP *) &myop;
536     myop.op_next = Nullop;
537     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
538     CATCH_SET(TRUE);
539
540     ENTER;
541     SAVEOP();
542     op = (OP *) &myop;
543     if (PERLDB_SUB && curstash != debstash)
544         op->op_private |= OPpENTERSUB_DB;
545
546     XPUSHs((SV*)GvCV(gv));
547     PUTBACK;
548
549     if (op = pp_entersub(ARGS))
550         runops();
551     SPAGAIN;
552
553     CATCH_SET(oldcatch);
554     sv = TOPs;
555     if (sv_isobject(sv)) {
556         if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
557             sv_unmagic(varsv, 'P');
558             sv_magic(varsv, sv, 'P', Nullch, 0);
559         }
560         else {
561             sv_unmagic(varsv, 'q');
562             sv_magic(varsv, sv, 'q', Nullch, 0);
563         }
564     }
565     LEAVE;
566     SP = stack_base + markoff;
567     PUSHs(sv);
568     RETURN;
569 }
570
571 PP(pp_untie)
572 {
573     dSP;
574     SV * sv ;
575
576     sv = POPs;
577
578     if (dowarn) {
579         MAGIC * mg ;
580         if (SvMAGICAL(sv)) {
581             if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
582                 mg = mg_find(sv, 'P') ;
583             else
584                 mg = mg_find(sv, 'q') ;
585     
586             if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)  
587                 warn("untie attempted while %lu inner references still exist",
588                         (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
589         }
590     }
591  
592     if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
593         sv_unmagic(sv, 'P');
594     else
595         sv_unmagic(sv, 'q');
596     RETPUSHYES;
597 }
598
599 PP(pp_tied)
600 {
601     dSP;
602     SV * sv ;
603     MAGIC * mg ;
604
605     sv = POPs;
606     if (SvMAGICAL(sv)) {
607         if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
608             mg = mg_find(sv, 'P') ;
609         else
610             mg = mg_find(sv, 'q') ;
611
612         if (mg)  {
613             PUSHs(sv_2mortal(newSVsv(mg->mg_obj))) ; 
614             RETURN ;
615         }
616     }
617
618     RETPUSHUNDEF;
619 }
620
621 PP(pp_dbmopen)
622 {
623     dSP;
624     HV *hv;
625     dPOPPOPssrl;
626     HV* stash;
627     GV *gv;
628     BINOP myop;
629     SV *sv;
630     bool oldcatch = CATCH_GET;
631
632     hv = (HV*)POPs;
633
634     sv = sv_mortalcopy(&sv_no);
635     sv_setpv(sv, "AnyDBM_File");
636     stash = gv_stashsv(sv, FALSE);
637     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
638         PUTBACK;
639         perl_require_pv("AnyDBM_File.pm");
640         SPAGAIN;
641         if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
642             DIE("No dbm on this machine");
643     }
644
645     Zero(&myop, 1, BINOP);
646     myop.op_last = (OP *) &myop;
647     myop.op_next = Nullop;
648     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
649     CATCH_SET(TRUE);
650
651     ENTER;
652     SAVEOP();
653     op = (OP *) &myop;
654     if (PERLDB_SUB && curstash != debstash)
655         op->op_private |= OPpENTERSUB_DB;
656     PUTBACK;
657     pp_pushmark(ARGS);
658
659     EXTEND(sp, 5);
660     PUSHs(sv);
661     PUSHs(left);
662     if (SvIV(right))
663         PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
664     else
665         PUSHs(sv_2mortal(newSViv(O_RDWR)));
666     PUSHs(right);
667     PUSHs((SV*)GvCV(gv));
668     PUTBACK;
669
670     if (op = pp_entersub(ARGS))
671         runops();
672     SPAGAIN;
673
674     if (!sv_isobject(TOPs)) {
675         sp--;
676         op = (OP *) &myop;
677         PUTBACK;
678         pp_pushmark(ARGS);
679
680         PUSHs(sv);
681         PUSHs(left);
682         PUSHs(sv_2mortal(newSViv(O_RDONLY)));
683         PUSHs(right);
684         PUSHs((SV*)GvCV(gv));
685         PUTBACK;
686
687         if (op = pp_entersub(ARGS))
688             runops();
689         SPAGAIN;
690     }
691
692     CATCH_SET(oldcatch);
693     if (sv_isobject(TOPs))
694         sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
695     LEAVE;
696     RETURN;
697 }
698
699 PP(pp_dbmclose)
700 {
701     return pp_untie(ARGS);
702 }
703
704 PP(pp_sselect)
705 {
706     dSP; dTARGET;
707 #ifdef HAS_SELECT
708     register I32 i;
709     register I32 j;
710     register char *s;
711     register SV *sv;
712     double value;
713     I32 maxlen = 0;
714     I32 nfound;
715     struct timeval timebuf;
716     struct timeval *tbuf = &timebuf;
717     I32 growsize;
718     char *fd_sets[4];
719 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
720         I32 masksize;
721         I32 offset;
722         I32 k;
723
724 #   if BYTEORDER & 0xf0000
725 #       define ORDERBYTE (0x88888888 - BYTEORDER)
726 #   else
727 #       define ORDERBYTE (0x4444 - BYTEORDER)
728 #   endif
729
730 #endif
731
732     SP -= 4;
733     for (i = 1; i <= 3; i++) {
734         if (!SvPOK(SP[i]))
735             continue;
736         j = SvCUR(SP[i]);
737         if (maxlen < j)
738             maxlen = j;
739     }
740
741 #if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
742 #if defined(__linux__) || defined(OS2)
743     growsize = sizeof(fd_set);
744 #else
745     growsize = maxlen;          /* little endians can use vecs directly */
746 #endif
747 #else
748 #ifdef NFDBITS
749
750 #ifndef NBBY
751 #define NBBY 8
752 #endif
753
754     masksize = NFDBITS / NBBY;
755 #else
756     masksize = sizeof(long);    /* documented int, everyone seems to use long */
757 #endif
758     growsize = maxlen + (masksize - (maxlen % masksize));
759     Zero(&fd_sets[0], 4, char*);
760 #endif
761
762     sv = SP[4];
763     if (SvOK(sv)) {
764         value = SvNV(sv);
765         if (value < 0.0)
766             value = 0.0;
767         timebuf.tv_sec = (long)value;
768         value -= (double)timebuf.tv_sec;
769         timebuf.tv_usec = (long)(value * 1000000.0);
770     }
771     else
772         tbuf = Null(struct timeval*);
773
774     for (i = 1; i <= 3; i++) {
775         sv = SP[i];
776         if (!SvOK(sv)) {
777             fd_sets[i] = 0;
778             continue;
779         }
780         else if (!SvPOK(sv))
781             SvPV_force(sv,na);  /* force string conversion */
782         j = SvLEN(sv);
783         if (j < growsize) {
784             Sv_Grow(sv, growsize);
785         }
786         j = SvCUR(sv);
787         s = SvPVX(sv) + j;
788         while (++j <= growsize) {
789             *s++ = '\0';
790         }
791
792 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
793         s = SvPVX(sv);
794         New(403, fd_sets[i], growsize, char);
795         for (offset = 0; offset < growsize; offset += masksize) {
796             for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
797                 fd_sets[i][j+offset] = s[(k % masksize) + offset];
798         }
799 #else
800         fd_sets[i] = SvPVX(sv);
801 #endif
802     }
803
804     nfound = select(
805         maxlen * 8,
806         (Select_fd_set_t) fd_sets[1],
807         (Select_fd_set_t) fd_sets[2],
808         (Select_fd_set_t) fd_sets[3],
809         tbuf);
810     for (i = 1; i <= 3; i++) {
811         if (fd_sets[i]) {
812             sv = SP[i];
813 #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
814             s = SvPVX(sv);
815             for (offset = 0; offset < growsize; offset += masksize) {
816                 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
817                     s[(k % masksize) + offset] = fd_sets[i][j+offset];
818             }
819             Safefree(fd_sets[i]);
820 #endif
821             SvSETMAGIC(sv);
822         }
823     }
824
825     PUSHi(nfound);
826     if (GIMME == G_ARRAY && tbuf) {
827         value = (double)(timebuf.tv_sec) +
828                 (double)(timebuf.tv_usec) / 1000000.0;
829         PUSHs(sv = sv_mortalcopy(&sv_no));
830         sv_setnv(sv, value);
831     }
832     RETURN;
833 #else
834     DIE("select not implemented");
835 #endif
836 }
837
838 void
839 setdefout(GV *gv)
840 {
841     dTHR;
842     if (gv)
843         (void)SvREFCNT_inc(gv);
844     if (defoutgv)
845         SvREFCNT_dec(defoutgv);
846     defoutgv = gv;
847 }
848
849 PP(pp_select)
850 {
851     dSP; dTARGET;
852     GV *newdefout, *egv;
853     HV *hv;
854
855     newdefout = (op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
856
857     egv = GvEGV(defoutgv);
858     if (!egv)
859         egv = defoutgv;
860     hv = GvSTASH(egv);
861     if (! hv)
862         XPUSHs(&sv_undef);
863     else {
864         GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
865         if (gvp && *gvp == egv) {
866             gv_efullname3(TARG, defoutgv, Nullch);
867             XPUSHTARG;
868         }
869         else {
870             XPUSHs(sv_2mortal(newRV((SV*)egv)));
871         }
872     }
873
874     if (newdefout) {
875         if (!GvIO(newdefout))
876             gv_IOadd(newdefout);
877         setdefout(newdefout);
878     }
879
880     RETURN;
881 }
882
883 PP(pp_getc)
884 {
885     dSP; dTARGET;
886     GV *gv;
887     MAGIC *mg;
888
889     if (MAXARG <= 0)
890         gv = stdingv;
891     else
892         gv = (GV*)POPs;
893     if (!gv)
894         gv = argvgv;
895
896     if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
897         I32 gimme = GIMME_V;
898         PUSHMARK(SP);
899         XPUSHs(mg->mg_obj);
900         PUTBACK;
901         ENTER;
902         perl_call_method("GETC", gimme);
903         LEAVE;
904         SPAGAIN;
905         if (gimme == G_SCALAR)
906             SvSetMagicSV_nosteal(TARG, TOPs);
907         RETURN;
908     }
909     if (!gv || do_eof(gv)) /* make sure we have fp with something */
910         RETPUSHUNDEF;
911     TAINT;
912     sv_setpv(TARG, " ");
913     *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
914     PUSHTARG;
915     RETURN;
916 }
917
918 PP(pp_read)
919 {
920     return pp_sysread(ARGS);
921 }
922
923 static OP *
924 doform(CV *cv, GV *gv, OP *retop)
925 {
926     dTHR;
927     register CONTEXT *cx;
928     I32 gimme = GIMME_V;
929     AV* padlist = CvPADLIST(cv);
930     SV** svp = AvARRAY(padlist);
931
932     ENTER;
933     SAVETMPS;
934
935     push_return(retop);
936     PUSHBLOCK(cx, CXt_SUB, stack_sp);
937     PUSHFORMAT(cx);
938     SAVESPTR(curpad);
939     curpad = AvARRAY((AV*)svp[1]);
940
941     setdefout(gv);          /* locally select filehandle so $% et al work */
942     return CvSTART(cv);
943 }
944
945 PP(pp_enterwrite)
946 {
947     dSP;
948     register GV *gv;
949     register IO *io;
950     GV *fgv;
951     CV *cv;
952
953     if (MAXARG == 0)
954         gv = defoutgv;
955     else {
956         gv = (GV*)POPs;
957         if (!gv)
958             gv = defoutgv;
959     }
960     EXTEND(SP, 1);
961     io = GvIO(gv);
962     if (!io) {
963         RETPUSHNO;
964     }
965     if (IoFMT_GV(io))
966         fgv = IoFMT_GV(io);
967     else
968         fgv = gv;
969
970     cv = GvFORM(fgv);
971     if (!cv) {
972         if (fgv) {
973             SV *tmpsv = sv_newmortal();
974             gv_efullname3(tmpsv, fgv, Nullch);
975             DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
976         }
977         DIE("Not a format reference");
978     }
979     if (CvCLONE(cv))
980         cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
981
982     IoFLAGS(io) &= ~IOf_DIDTOP;
983     return doform(cv,gv,op->op_next);
984 }
985
986 PP(pp_leavewrite)
987 {
988     dSP;
989     GV *gv = cxstack[cxstack_ix].blk_sub.gv;
990     register IO *io = GvIOp(gv);
991     PerlIO *ofp = IoOFP(io);
992     PerlIO *fp;
993     SV **newsp;
994     I32 gimme;
995     register CONTEXT *cx;
996
997     DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
998           (long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
999     if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
1000         formtarget != toptarget)
1001     {
1002         GV *fgv;
1003         CV *cv;
1004         if (!IoTOP_GV(io)) {
1005             GV *topgv;
1006             SV *topname;
1007
1008             if (!IoTOP_NAME(io)) {
1009                 if (!IoFMT_NAME(io))
1010                     IoFMT_NAME(io) = savepv(GvNAME(gv));
1011                 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1012                 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
1013                 if ((topgv && GvFORM(topgv)) ||
1014                   !gv_fetchpv("top",FALSE,SVt_PVFM))
1015                     IoTOP_NAME(io) = savepv(SvPVX(topname));
1016                 else
1017                     IoTOP_NAME(io) = savepv("top");
1018             }
1019             topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1020             if (!topgv || !GvFORM(topgv)) {
1021                 IoLINES_LEFT(io) = 100000000;
1022                 goto forget_top;
1023             }
1024             IoTOP_GV(io) = topgv;
1025         }
1026         if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear.  It still doesn't fit. */
1027             I32 lines = IoLINES_LEFT(io);
1028             char *s = SvPVX(formtarget);
1029             if (lines <= 0)             /* Yow, header didn't even fit!!! */
1030                 goto forget_top;
1031             while (lines-- > 0) {
1032                 s = strchr(s, '\n');
1033                 if (!s)
1034                     break;
1035                 s++;
1036             }
1037             if (s) {
1038                 PerlIO_write(ofp, SvPVX(formtarget), s - SvPVX(formtarget));
1039                 sv_chop(formtarget, s);
1040                 FmLINES(formtarget) -= IoLINES_LEFT(io);
1041             }
1042         }
1043         if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
1044             PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed));
1045         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1046         IoPAGE(io)++;
1047         formtarget = toptarget;
1048         IoFLAGS(io) |= IOf_DIDTOP;
1049         fgv = IoTOP_GV(io);
1050         if (!fgv)
1051             DIE("bad top format reference");
1052         cv = GvFORM(fgv);
1053         if (!cv) {
1054             SV *tmpsv = sv_newmortal();
1055             gv_efullname3(tmpsv, fgv, Nullch);
1056             DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1057         }
1058         if (CvCLONE(cv))
1059             cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
1060         return doform(cv,gv,op);
1061     }
1062
1063   forget_top:
1064     POPBLOCK(cx,curpm);
1065     POPFORMAT(cx);
1066     LEAVE;
1067
1068     fp = IoOFP(io);
1069     if (!fp) {
1070         if (dowarn) {
1071             if (IoIFP(io))
1072                 warn("Filehandle only opened for input");
1073             else
1074                 warn("Write on closed filehandle");
1075         }
1076         PUSHs(&sv_no);
1077     }
1078     else {
1079         if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
1080             if (dowarn)
1081                 warn("page overflow");
1082         }
1083         if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) ||
1084                 PerlIO_error(fp))
1085             PUSHs(&sv_no);
1086         else {
1087             FmLINES(formtarget) = 0;
1088             SvCUR_set(formtarget, 0);
1089             *SvEND(formtarget) = '\0';
1090             if (IoFLAGS(io) & IOf_FLUSH)
1091                 (void)PerlIO_flush(fp);
1092             PUSHs(&sv_yes);
1093         }
1094     }
1095     formtarget = bodytarget;
1096     PUTBACK;
1097     return pop_return();
1098 }
1099
1100 PP(pp_prtf)
1101 {
1102     dSP; dMARK; dORIGMARK;
1103     GV *gv;
1104     IO *io;
1105     PerlIO *fp;
1106     SV *sv;
1107     MAGIC *mg;
1108
1109     if (op->op_flags & OPf_STACKED)
1110         gv = (GV*)*++MARK;
1111     else
1112         gv = defoutgv;
1113
1114     if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
1115         if (MARK == ORIGMARK) {
1116             EXTEND(SP, 1);
1117             ++MARK;
1118             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1119             ++SP;
1120         }
1121         PUSHMARK(MARK - 1);
1122         *MARK = mg->mg_obj;
1123         PUTBACK;
1124         ENTER;
1125         perl_call_method("PRINTF", G_SCALAR);
1126         LEAVE;
1127         SPAGAIN;
1128         MARK = ORIGMARK + 1;
1129         *MARK = *SP;
1130         SP = MARK;
1131         RETURN;
1132     }
1133
1134     sv = NEWSV(0,0);
1135     if (!(io = GvIO(gv))) {
1136         if (dowarn) {
1137             gv_fullname3(sv, gv, Nullch);
1138             warn("Filehandle %s never opened", SvPV(sv,na));
1139         }
1140         SETERRNO(EBADF,RMS$_IFI);
1141         goto just_say_no;
1142     }
1143     else if (!(fp = IoOFP(io))) {
1144         if (dowarn)  {
1145             gv_fullname3(sv, gv, Nullch);
1146             if (IoIFP(io))
1147                 warn("Filehandle %s opened only for input", SvPV(sv,na));
1148             else
1149                 warn("printf on closed filehandle %s", SvPV(sv,na));
1150         }
1151         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
1152         goto just_say_no;
1153     }
1154     else {
1155 #ifdef USE_LOCALE_NUMERIC
1156         if (op->op_private & OPpLOCALE)
1157             SET_NUMERIC_LOCAL();
1158         else
1159             SET_NUMERIC_STANDARD();
1160 #endif
1161         do_sprintf(sv, SP - MARK, MARK + 1);
1162         if (!do_print(sv, fp))
1163             goto just_say_no;
1164
1165         if (IoFLAGS(io) & IOf_FLUSH)
1166             if (PerlIO_flush(fp) == EOF)
1167                 goto just_say_no;
1168     }
1169     SvREFCNT_dec(sv);
1170     SP = ORIGMARK;
1171     PUSHs(&sv_yes);
1172     RETURN;
1173
1174   just_say_no:
1175     SvREFCNT_dec(sv);
1176     SP = ORIGMARK;
1177     PUSHs(&sv_undef);
1178     RETURN;
1179 }
1180
1181 PP(pp_sysopen)
1182 {
1183     dSP;
1184     GV *gv;
1185     SV *sv;
1186     char *tmps;
1187     STRLEN len;
1188     int mode, perm;
1189
1190     if (MAXARG > 3)
1191         perm = POPi;
1192     else
1193         perm = 0666;
1194     mode = POPi;
1195     sv = POPs;
1196     gv = (GV *)POPs;
1197
1198     tmps = SvPV(sv, len);
1199     if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1200         IoLINES(GvIOp(gv)) = 0;
1201         PUSHs(&sv_yes);
1202     }
1203     else {
1204         PUSHs(&sv_undef);
1205     }
1206     RETURN;
1207 }
1208
1209 PP(pp_sysread)
1210 {
1211     dSP; dMARK; dORIGMARK; dTARGET;
1212     int offset;
1213     GV *gv;
1214     IO *io;
1215     char *buffer;
1216     SSize_t length;
1217     Sock_size_t bufsize;
1218     SV *bufsv;
1219     STRLEN blen;
1220     MAGIC *mg;
1221
1222     gv = (GV*)*++MARK;
1223     if ((op->op_type == OP_READ || op->op_type == OP_SYSREAD) &&
1224         SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q')))
1225     {
1226         SV *sv;
1227         
1228         PUSHMARK(MARK-1);
1229         *MARK = mg->mg_obj;
1230         ENTER;
1231         perl_call_method("READ", G_SCALAR);
1232         LEAVE;
1233         SPAGAIN;
1234         sv = POPs;
1235         SP = ORIGMARK;
1236         PUSHs(sv);
1237         RETURN;
1238     }
1239
1240     if (!gv)
1241         goto say_undef;
1242     bufsv = *++MARK;
1243     if (! SvOK(bufsv))
1244         sv_setpvn(bufsv, "", 0);
1245     buffer = SvPV_force(bufsv, blen);
1246     length = SvIVx(*++MARK);
1247     if (length < 0)
1248         DIE("Negative length");
1249     SETERRNO(0,0);
1250     if (MARK < SP)
1251         offset = SvIVx(*++MARK);
1252     else
1253         offset = 0;
1254     io = GvIO(gv);
1255     if (!io || !IoIFP(io))
1256         goto say_undef;
1257 #ifdef HAS_SOCKET
1258     if (op->op_type == OP_RECV) {
1259         char namebuf[MAXPATHLEN];
1260 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1261         bufsize = sizeof (struct sockaddr_in);
1262 #else
1263         bufsize = sizeof namebuf;
1264 #endif
1265         buffer = SvGROW(bufsv, length+1);
1266         /* 'offset' means 'flags' here */
1267         length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1268                           (struct sockaddr *)namebuf, &bufsize);
1269         if (length < 0)
1270             RETPUSHUNDEF;
1271         SvCUR_set(bufsv, length);
1272         *SvEND(bufsv) = '\0';
1273         (void)SvPOK_only(bufsv);
1274         SvSETMAGIC(bufsv);
1275         /* This should not be marked tainted if the fp is marked clean */
1276         if (!(IoFLAGS(io) & IOf_UNTAINT))
1277             SvTAINTED_on(bufsv);
1278         SP = ORIGMARK;
1279         sv_setpvn(TARG, namebuf, bufsize);
1280         PUSHs(TARG);
1281         RETURN;
1282     }
1283 #else
1284     if (op->op_type == OP_RECV)
1285         DIE(no_sock_func, "recv");
1286 #endif
1287     if (offset < 0) {
1288         if (-offset > blen)
1289             DIE("Offset outside string");
1290         offset += blen;
1291     }
1292     bufsize = SvCUR(bufsv);
1293     buffer = SvGROW(bufsv, length+offset+1);
1294     if (offset > bufsize) { /* Zero any newly allocated space */
1295         Zero(buffer+bufsize, offset-bufsize, char);
1296     }
1297     if (op->op_type == OP_SYSREAD) {
1298         length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1299     }
1300     else
1301 #ifdef HAS_SOCKET__bad_code_maybe
1302     if (IoTYPE(io) == 's') {
1303         char namebuf[MAXPATHLEN];
1304 #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1305         bufsize = sizeof (struct sockaddr_in);
1306 #else
1307         bufsize = sizeof namebuf;
1308 #endif
1309         length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
1310                           (struct sockaddr *)namebuf, &bufsize);
1311     }
1312     else
1313 #endif
1314         length = PerlIO_read(IoIFP(io), buffer+offset, length);
1315     if (length < 0)
1316         goto say_undef;
1317     SvCUR_set(bufsv, length+offset);
1318     *SvEND(bufsv) = '\0';
1319     (void)SvPOK_only(bufsv);
1320     SvSETMAGIC(bufsv);
1321     /* This should not be marked tainted if the fp is marked clean */
1322     if (!(IoFLAGS(io) & IOf_UNTAINT))
1323         SvTAINTED_on(bufsv);
1324     SP = ORIGMARK;
1325     PUSHi(length);
1326     RETURN;
1327
1328   say_undef:
1329     SP = ORIGMARK;
1330     RETPUSHUNDEF;
1331 }
1332
1333 PP(pp_syswrite)
1334 {
1335     return pp_send(ARGS);
1336 }
1337
1338 PP(pp_send)
1339 {
1340     dSP; dMARK; dORIGMARK; dTARGET;
1341     GV *gv;
1342     IO *io;
1343     int offset;
1344     SV *bufsv;
1345     char *buffer;
1346     int length;
1347     STRLEN blen;
1348
1349     gv = (GV*)*++MARK;
1350     if (!gv)
1351         goto say_undef;
1352     bufsv = *++MARK;
1353     buffer = SvPV(bufsv, blen);
1354     length = SvIVx(*++MARK);
1355     if (length < 0)
1356         DIE("Negative length");
1357     SETERRNO(0,0);
1358     io = GvIO(gv);
1359     if (!io || !IoIFP(io)) {
1360         length = -1;
1361         if (dowarn) {
1362             if (op->op_type == OP_SYSWRITE)
1363                 warn("Syswrite on closed filehandle");
1364             else
1365                 warn("Send on closed socket");
1366         }
1367     }
1368     else if (op->op_type == OP_SYSWRITE) {
1369         if (MARK < SP) {
1370             offset = SvIVx(*++MARK);
1371             if (offset < 0) {
1372                 if (-offset > blen)
1373                     DIE("Offset outside string");
1374                 offset += blen;
1375             } else if (offset >= blen && blen > 0)
1376                 DIE("Offset outside string");
1377         } else
1378             offset = 0;
1379         if (length > blen - offset)
1380             length = blen - offset;
1381         length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
1382     }
1383 #ifdef HAS_SOCKET
1384     else if (SP > MARK) {
1385         char *sockbuf;
1386         STRLEN mlen;
1387         sockbuf = SvPVx(*++MARK, mlen);
1388         length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
1389                                 (struct sockaddr *)sockbuf, mlen);
1390     }
1391     else
1392         length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
1393
1394 #else
1395     else
1396         DIE(no_sock_func, "send");
1397 #endif
1398     if (length < 0)
1399         goto say_undef;
1400     SP = ORIGMARK;
1401     PUSHi(length);
1402     RETURN;
1403
1404   say_undef:
1405     SP = ORIGMARK;
1406     RETPUSHUNDEF;
1407 }
1408
1409 PP(pp_recv)
1410 {
1411     return pp_sysread(ARGS);
1412 }
1413
1414 PP(pp_eof)
1415 {
1416     dSP;
1417     GV *gv;
1418
1419     if (MAXARG <= 0)
1420         gv = last_in_gv;
1421     else
1422         gv = last_in_gv = (GV*)POPs;
1423     PUSHs(boolSV(!gv || do_eof(gv)));
1424     RETURN;
1425 }
1426
1427 PP(pp_tell)
1428 {
1429     dSP; dTARGET;
1430     GV *gv;
1431
1432     if (MAXARG <= 0)
1433         gv = last_in_gv;
1434     else
1435         gv = last_in_gv = (GV*)POPs;
1436     PUSHi( do_tell(gv) );
1437     RETURN;
1438 }
1439
1440 PP(pp_seek)
1441 {
1442     return pp_sysseek(ARGS);
1443 }
1444
1445 PP(pp_sysseek)
1446 {
1447     dSP;
1448     GV *gv;
1449     int whence = POPi;
1450     long offset = POPl;
1451
1452     gv = last_in_gv = (GV*)POPs;
1453     if (op->op_type == OP_SEEK)
1454         PUSHs(boolSV(do_seek(gv, offset, whence)));
1455     else {
1456         long n = do_sysseek(gv, offset, whence);
1457         PUSHs((n < 0) ? &sv_undef
1458               : sv_2mortal(n ? newSViv((IV)n)
1459                            : newSVpv(zero_but_true, ZBTLEN)));
1460     }
1461     RETURN;
1462 }
1463
1464 PP(pp_truncate)
1465 {
1466     dSP;
1467     Off_t len = (Off_t)POPn;
1468     int result = 1;
1469     GV *tmpgv;
1470
1471     SETERRNO(0,0);
1472 #if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
1473     if (op->op_flags & OPf_SPECIAL) {
1474         tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
1475     do_ftruncate:
1476         TAINT_PROPER("truncate");
1477         if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
1478 #ifdef HAS_TRUNCATE
1479           ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1480 #else 
1481           my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
1482 #endif
1483             result = 0;
1484     }
1485     else {
1486         SV *sv = POPs;
1487         char *name;
1488
1489         if (SvTYPE(sv) == SVt_PVGV) {
1490             tmpgv = (GV*)sv;            /* *main::FRED for example */
1491             goto do_ftruncate;
1492         }
1493         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1494             tmpgv = (GV*) SvRV(sv);     /* \*main::FRED for example */
1495             goto do_ftruncate;
1496         }
1497
1498         name = SvPV(sv, na);
1499         TAINT_PROPER("truncate");
1500 #ifdef HAS_TRUNCATE
1501         if (truncate(name, len) < 0)
1502             result = 0;
1503 #else
1504         {
1505             int tmpfd;
1506             if ((tmpfd = open(name, O_RDWR)) < 0)
1507                 result = 0;
1508             else {
1509                 if (my_chsize(tmpfd, len) < 0)
1510                     result = 0;
1511                 close(tmpfd);
1512             }
1513         }
1514 #endif
1515     }
1516
1517     if (result)
1518         RETPUSHYES;
1519     if (!errno)
1520         SETERRNO(EBADF,RMS$_IFI);
1521     RETPUSHUNDEF;
1522 #else
1523     DIE("truncate not implemented");
1524 #endif
1525 }
1526
1527 PP(pp_fcntl)
1528 {
1529     return pp_ioctl(ARGS);
1530 }
1531
1532 PP(pp_ioctl)
1533 {
1534     dSP; dTARGET;
1535     SV *argsv = POPs;
1536     unsigned int func = U_I(POPn);
1537     int optype = op->op_type;
1538     char *s;
1539     IV retval;
1540     GV *gv = (GV*)POPs;
1541     IO *io = GvIOn(gv);
1542
1543     if (!io || !argsv || !IoIFP(io)) {
1544         SETERRNO(EBADF,RMS$_IFI);       /* well, sort of... */
1545         RETPUSHUNDEF;
1546     }
1547
1548     if (SvPOK(argsv) || !SvNIOK(argsv)) {
1549         STRLEN len;
1550         STRLEN need;
1551         s = SvPV_force(argsv, len);
1552         need = IOCPARM_LEN(func);
1553         if (len < need) {
1554             s = Sv_Grow(argsv, need + 1);
1555             SvCUR_set(argsv, need);
1556         }
1557
1558         s[SvCUR(argsv)] = 17;   /* a little sanity check here */
1559     }
1560     else {
1561         retval = SvIV(argsv);
1562         s = (char*)retval;              /* ouch */
1563     }
1564
1565     TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1566
1567     if (optype == OP_IOCTL)
1568 #ifdef HAS_IOCTL
1569         retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
1570 #else
1571         DIE("ioctl is not implemented");
1572 #endif
1573     else
1574 #ifdef HAS_FCNTL
1575 #if defined(OS2) && defined(__EMX__)
1576         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
1577 #else
1578         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
1579 #endif 
1580 #else
1581         DIE("fcntl is not implemented");
1582 #endif
1583
1584     if (SvPOK(argsv)) {
1585         if (s[SvCUR(argsv)] != 17)
1586             DIE("Possible memory corruption: %s overflowed 3rd argument",
1587                 op_name[optype]);
1588         s[SvCUR(argsv)] = 0;            /* put our null back */
1589         SvSETMAGIC(argsv);              /* Assume it has changed */
1590     }
1591
1592     if (retval == -1)
1593         RETPUSHUNDEF;
1594     if (retval != 0) {
1595         PUSHi(retval);
1596     }
1597     else {
1598         PUSHp(zero_but_true, ZBTLEN);
1599     }
1600     RETURN;
1601 }
1602
1603 PP(pp_flock)
1604 {
1605     dSP; dTARGET;
1606     I32 value;
1607     int argtype;
1608     GV *gv;
1609     PerlIO *fp;
1610
1611 #ifdef FLOCK
1612     argtype = POPi;
1613     if (MAXARG <= 0)
1614         gv = last_in_gv;
1615     else
1616         gv = (GV*)POPs;
1617     if (gv && GvIO(gv))
1618         fp = IoIFP(GvIOp(gv));
1619     else
1620         fp = Nullfp;
1621     if (fp) {
1622         (void)PerlIO_flush(fp);
1623         value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
1624     }
1625     else
1626         value = 0;
1627     PUSHi(value);
1628     RETURN;
1629 #else
1630     DIE(no_func, "flock()");
1631 #endif
1632 }
1633
1634 /* Sockets. */
1635
1636 PP(pp_socket)
1637 {
1638     dSP;
1639 #ifdef HAS_SOCKET
1640     GV *gv;
1641     register IO *io;
1642     int protocol = POPi;
1643     int type = POPi;
1644     int domain = POPi;
1645     int fd;
1646
1647     gv = (GV*)POPs;
1648
1649     if (!gv) {
1650         SETERRNO(EBADF,LIB$_INVARG);
1651         RETPUSHUNDEF;
1652     }
1653
1654     io = GvIOn(gv);
1655     if (IoIFP(io))
1656         do_close(gv, FALSE);
1657
1658     TAINT_PROPER("socket");
1659     fd = socket(domain, type, protocol);
1660     if (fd < 0)
1661         RETPUSHUNDEF;
1662     IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1663     IoOFP(io) = PerlIO_fdopen(fd, "w");
1664     IoTYPE(io) = 's';
1665     if (!IoIFP(io) || !IoOFP(io)) {
1666         if (IoIFP(io)) PerlIO_close(IoIFP(io));
1667         if (IoOFP(io)) PerlIO_close(IoOFP(io));
1668         if (!IoIFP(io) && !IoOFP(io)) close(fd);
1669         RETPUSHUNDEF;
1670     }
1671
1672     RETPUSHYES;
1673 #else
1674     DIE(no_sock_func, "socket");
1675 #endif
1676 }
1677
1678 PP(pp_sockpair)
1679 {
1680     dSP;
1681 #ifdef HAS_SOCKETPAIR
1682     GV *gv1;
1683     GV *gv2;
1684     register IO *io1;
1685     register IO *io2;
1686     int protocol = POPi;
1687     int type = POPi;
1688     int domain = POPi;
1689     int fd[2];
1690
1691     gv2 = (GV*)POPs;
1692     gv1 = (GV*)POPs;
1693     if (!gv1 || !gv2)
1694         RETPUSHUNDEF;
1695
1696     io1 = GvIOn(gv1);
1697     io2 = GvIOn(gv2);
1698     if (IoIFP(io1))
1699         do_close(gv1, FALSE);
1700     if (IoIFP(io2))
1701         do_close(gv2, FALSE);
1702
1703     TAINT_PROPER("socketpair");
1704     if (socketpair(domain, type, protocol, fd) < 0)
1705         RETPUSHUNDEF;
1706     IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1707     IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
1708     IoTYPE(io1) = 's';
1709     IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1710     IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
1711     IoTYPE(io2) = 's';
1712     if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
1713         if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1714         if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
1715         if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
1716         if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1717         if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
1718         if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
1719         RETPUSHUNDEF;
1720     }
1721
1722     RETPUSHYES;
1723 #else
1724     DIE(no_sock_func, "socketpair");
1725 #endif
1726 }
1727
1728 PP(pp_bind)
1729 {
1730     dSP;
1731 #ifdef HAS_SOCKET
1732     SV *addrsv = POPs;
1733     char *addr;
1734     GV *gv = (GV*)POPs;
1735     register IO *io = GvIOn(gv);
1736     STRLEN len;
1737
1738     if (!io || !IoIFP(io))
1739         goto nuts;
1740
1741     addr = SvPV(addrsv, len);
1742     TAINT_PROPER("bind");
1743     if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1744         RETPUSHYES;
1745     else
1746         RETPUSHUNDEF;
1747
1748 nuts:
1749     if (dowarn)
1750         warn("bind() on closed fd");
1751     SETERRNO(EBADF,SS$_IVCHAN);
1752     RETPUSHUNDEF;
1753 #else
1754     DIE(no_sock_func, "bind");
1755 #endif
1756 }
1757
1758 PP(pp_connect)
1759 {
1760     dSP;
1761 #ifdef HAS_SOCKET
1762     SV *addrsv = POPs;
1763     char *addr;
1764     GV *gv = (GV*)POPs;
1765     register IO *io = GvIOn(gv);
1766     STRLEN len;
1767
1768     if (!io || !IoIFP(io))
1769         goto nuts;
1770
1771     addr = SvPV(addrsv, len);
1772     TAINT_PROPER("connect");
1773     if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
1774         RETPUSHYES;
1775     else
1776         RETPUSHUNDEF;
1777
1778 nuts:
1779     if (dowarn)
1780         warn("connect() on closed fd");
1781     SETERRNO(EBADF,SS$_IVCHAN);
1782     RETPUSHUNDEF;
1783 #else
1784     DIE(no_sock_func, "connect");
1785 #endif
1786 }
1787
1788 PP(pp_listen)
1789 {
1790     dSP;
1791 #ifdef HAS_SOCKET
1792     int backlog = POPi;
1793     GV *gv = (GV*)POPs;
1794     register IO *io = GvIOn(gv);
1795
1796     if (!io || !IoIFP(io))
1797         goto nuts;
1798
1799     if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
1800         RETPUSHYES;
1801     else
1802         RETPUSHUNDEF;
1803
1804 nuts:
1805     if (dowarn)
1806         warn("listen() on closed fd");
1807     SETERRNO(EBADF,SS$_IVCHAN);
1808     RETPUSHUNDEF;
1809 #else
1810     DIE(no_sock_func, "listen");
1811 #endif
1812 }
1813
1814 PP(pp_accept)
1815 {
1816     dSP; dTARGET;
1817 #ifdef HAS_SOCKET
1818     GV *ngv;
1819     GV *ggv;
1820     register IO *nstio;
1821     register IO *gstio;
1822     struct sockaddr saddr;      /* use a struct to avoid alignment problems */
1823     Sock_size_t len = sizeof saddr;
1824     int fd;
1825
1826     ggv = (GV*)POPs;
1827     ngv = (GV*)POPs;
1828
1829     if (!ngv)
1830         goto badexit;
1831     if (!ggv)
1832         goto nuts;
1833
1834     gstio = GvIO(ggv);
1835     if (!gstio || !IoIFP(gstio))
1836         goto nuts;
1837
1838     nstio = GvIOn(ngv);
1839     if (IoIFP(nstio))
1840         do_close(ngv, FALSE);
1841
1842     fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
1843     if (fd < 0)
1844         goto badexit;
1845     IoIFP(nstio) = PerlIO_fdopen(fd, "r");
1846     IoOFP(nstio) = PerlIO_fdopen(fd, "w");
1847     IoTYPE(nstio) = 's';
1848     if (!IoIFP(nstio) || !IoOFP(nstio)) {
1849         if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
1850         if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
1851         if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
1852         goto badexit;
1853     }
1854
1855     PUSHp((char *)&saddr, len);
1856     RETURN;
1857
1858 nuts:
1859     if (dowarn)
1860         warn("accept() on closed fd");
1861     SETERRNO(EBADF,SS$_IVCHAN);
1862
1863 badexit:
1864     RETPUSHUNDEF;
1865
1866 #else
1867     DIE(no_sock_func, "accept");
1868 #endif
1869 }
1870
1871 PP(pp_shutdown)
1872 {
1873     dSP; dTARGET;
1874 #ifdef HAS_SOCKET
1875     int how = POPi;
1876     GV *gv = (GV*)POPs;
1877     register IO *io = GvIOn(gv);
1878
1879     if (!io || !IoIFP(io))
1880         goto nuts;
1881
1882     PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
1883     RETURN;
1884
1885 nuts:
1886     if (dowarn)
1887         warn("shutdown() on closed fd");
1888     SETERRNO(EBADF,SS$_IVCHAN);
1889     RETPUSHUNDEF;
1890 #else
1891     DIE(no_sock_func, "shutdown");
1892 #endif
1893 }
1894
1895 PP(pp_gsockopt)
1896 {
1897 #ifdef HAS_SOCKET
1898     return pp_ssockopt(ARGS);
1899 #else
1900     DIE(no_sock_func, "getsockopt");
1901 #endif
1902 }
1903
1904 PP(pp_ssockopt)
1905 {
1906     dSP;
1907 #ifdef HAS_SOCKET
1908     int optype = op->op_type;
1909     SV *sv;
1910     int fd;
1911     unsigned int optname;
1912     unsigned int lvl;
1913     GV *gv;
1914     register IO *io;
1915     Sock_size_t len;
1916
1917     if (optype == OP_GSOCKOPT)
1918         sv = sv_2mortal(NEWSV(22, 257));
1919     else
1920         sv = POPs;
1921     optname = (unsigned int) POPi;
1922     lvl = (unsigned int) POPi;
1923
1924     gv = (GV*)POPs;
1925     io = GvIOn(gv);
1926     if (!io || !IoIFP(io))
1927         goto nuts;
1928
1929     fd = PerlIO_fileno(IoIFP(io));
1930     switch (optype) {
1931     case OP_GSOCKOPT:
1932         SvGROW(sv, 257);
1933         (void)SvPOK_only(sv);
1934         SvCUR_set(sv,256);
1935         *SvEND(sv) ='\0';
1936         len = SvCUR(sv);
1937         if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
1938             goto nuts2;
1939         SvCUR_set(sv, len);
1940         *SvEND(sv) ='\0';
1941         PUSHs(sv);
1942         break;
1943     case OP_SSOCKOPT: {
1944             char *buf;
1945             int aint;
1946             if (SvPOKp(sv)) {
1947                 buf = SvPV(sv, na);
1948                 len = na;
1949             }
1950             else if (SvOK(sv)) {
1951                 aint = (int)SvIV(sv);
1952                 buf = (char*)&aint;
1953                 len = sizeof(int);
1954             }
1955             if (setsockopt(fd, lvl, optname, buf, len) < 0)
1956                 goto nuts2;
1957             PUSHs(&sv_yes);
1958         }
1959         break;
1960     }
1961     RETURN;
1962
1963 nuts:
1964     if (dowarn)
1965         warn("[gs]etsockopt() on closed fd");
1966     SETERRNO(EBADF,SS$_IVCHAN);
1967 nuts2:
1968     RETPUSHUNDEF;
1969
1970 #else
1971     DIE(no_sock_func, "setsockopt");
1972 #endif
1973 }
1974
1975 PP(pp_getsockname)
1976 {
1977 #ifdef HAS_SOCKET
1978     return pp_getpeername(ARGS);
1979 #else
1980     DIE(no_sock_func, "getsockname");
1981 #endif
1982 }
1983
1984 PP(pp_getpeername)
1985 {
1986     dSP;
1987 #ifdef HAS_SOCKET
1988     int optype = op->op_type;
1989     SV *sv;
1990     int fd;
1991     GV *gv = (GV*)POPs;
1992     register IO *io = GvIOn(gv);
1993     Sock_size_t len;
1994
1995     if (!io || !IoIFP(io))
1996         goto nuts;
1997
1998     sv = sv_2mortal(NEWSV(22, 257));
1999     (void)SvPOK_only(sv);
2000     len = 256;
2001     SvCUR_set(sv, len);
2002     *SvEND(sv) ='\0';
2003     fd = PerlIO_fileno(IoIFP(io));
2004     switch (optype) {
2005     case OP_GETSOCKNAME:
2006         if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2007             goto nuts2;
2008         break;
2009     case OP_GETPEERNAME:
2010         if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2011             goto nuts2;
2012 #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2013         {
2014             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";
2015             /* If the call succeeded, make sure we don't have a zeroed port/addr */
2016             if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2017                 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2018                         sizeof(u_short) + sizeof(struct in_addr))) {
2019                 goto nuts2;         
2020             }
2021         }
2022 #endif
2023         break;
2024     }
2025 #ifdef BOGUS_GETNAME_RETURN
2026     /* Interactive Unix, getpeername() and getsockname()
2027       does not return valid namelen */
2028     if (len == BOGUS_GETNAME_RETURN)
2029         len = sizeof(struct sockaddr);
2030 #endif
2031     SvCUR_set(sv, len);
2032     *SvEND(sv) ='\0';
2033     PUSHs(sv);
2034     RETURN;
2035
2036 nuts:
2037     if (dowarn)
2038         warn("get{sock, peer}name() on closed fd");
2039     SETERRNO(EBADF,SS$_IVCHAN);
2040 nuts2:
2041     RETPUSHUNDEF;
2042
2043 #else
2044     DIE(no_sock_func, "getpeername");
2045 #endif
2046 }
2047
2048 /* Stat calls. */
2049
2050 PP(pp_lstat)
2051 {
2052     return pp_stat(ARGS);
2053 }
2054
2055 PP(pp_stat)
2056 {
2057     dSP;
2058     GV *tmpgv;
2059     I32 gimme;
2060     I32 max = 13;
2061
2062     if (op->op_flags & OPf_REF) {
2063         tmpgv = cGVOP->op_gv;
2064       do_fstat:
2065         if (tmpgv != defgv) {
2066             laststype = OP_STAT;
2067             statgv = tmpgv;
2068             sv_setpv(statname, "");
2069             laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2070                 ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
2071         }
2072         if (laststatval < 0)
2073             max = 0;
2074     }
2075     else {
2076         SV* sv = POPs;
2077         if (SvTYPE(sv) == SVt_PVGV) {
2078             tmpgv = (GV*)sv;
2079             goto do_fstat;
2080         }
2081         else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2082             tmpgv = (GV*)SvRV(sv);
2083             goto do_fstat;
2084         }
2085         sv_setpv(statname, SvPV(sv,na));
2086         statgv = Nullgv;
2087 #ifdef HAS_LSTAT
2088         laststype = op->op_type;
2089         if (op->op_type == OP_LSTAT)
2090             laststatval = lstat(SvPV(statname, na), &statcache);
2091         else
2092 #endif
2093             laststatval = Stat(SvPV(statname, na), &statcache);
2094         if (laststatval < 0) {
2095             if (dowarn && strchr(SvPV(statname, na), '\n'))
2096                 warn(warn_nl, "stat");
2097             max = 0;
2098         }
2099     }
2100
2101     gimme = GIMME_V;
2102     if (gimme != G_ARRAY) {
2103         if (gimme != G_VOID)
2104             XPUSHs(boolSV(max));
2105         RETURN;
2106     }
2107     if (max) {
2108         EXTEND(SP, max);
2109         EXTEND_MORTAL(max);
2110         PUSHs(sv_2mortal(newSViv((I32)statcache.st_dev)));
2111         PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
2112         PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
2113         PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
2114         PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
2115         PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
2116 #ifdef USE_STAT_RDEV
2117         PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
2118 #else
2119         PUSHs(sv_2mortal(newSVpv("", 0)));
2120 #endif
2121         PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
2122 #ifdef BIG_TIME
2123         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
2124         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
2125         PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
2126 #else
2127         PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
2128         PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
2129         PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
2130 #endif
2131 #ifdef USE_STAT_BLOCKS
2132         PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
2133         PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
2134 #else
2135         PUSHs(sv_2mortal(newSVpv("", 0)));
2136         PUSHs(sv_2mortal(newSVpv("", 0)));
2137 #endif
2138     }
2139     RETURN;
2140 }
2141
2142 PP(pp_ftrread)
2143 {
2144     I32 result = my_stat(ARGS);
2145     dSP;
2146     if (result < 0)
2147         RETPUSHUNDEF;
2148     if (cando(S_IRUSR, 0, &statcache))
2149         RETPUSHYES;
2150     RETPUSHNO;
2151 }
2152
2153 PP(pp_ftrwrite)
2154 {
2155     I32 result = my_stat(ARGS);
2156     dSP;
2157     if (result < 0)
2158         RETPUSHUNDEF;
2159     if (cando(S_IWUSR, 0, &statcache))
2160         RETPUSHYES;
2161     RETPUSHNO;
2162 }
2163
2164 PP(pp_ftrexec)
2165 {
2166     I32 result = my_stat(ARGS);
2167     dSP;
2168     if (result < 0)
2169         RETPUSHUNDEF;
2170     if (cando(S_IXUSR, 0, &statcache))
2171         RETPUSHYES;
2172     RETPUSHNO;
2173 }
2174
2175 PP(pp_fteread)
2176 {
2177     I32 result = my_stat(ARGS);
2178     dSP;
2179     if (result < 0)
2180         RETPUSHUNDEF;
2181     if (cando(S_IRUSR, 1, &statcache))
2182         RETPUSHYES;
2183     RETPUSHNO;
2184 }
2185
2186 PP(pp_ftewrite)
2187 {
2188     I32 result = my_stat(ARGS);
2189     dSP;
2190     if (result < 0)
2191         RETPUSHUNDEF;
2192     if (cando(S_IWUSR, 1, &statcache))
2193         RETPUSHYES;
2194     RETPUSHNO;
2195 }
2196
2197 PP(pp_fteexec)
2198 {
2199     I32 result = my_stat(ARGS);
2200     dSP;
2201     if (result < 0)
2202         RETPUSHUNDEF;
2203     if (cando(S_IXUSR, 1, &statcache))
2204         RETPUSHYES;
2205     RETPUSHNO;
2206 }
2207
2208 PP(pp_ftis)
2209 {
2210     I32 result = my_stat(ARGS);
2211     dSP;
2212     if (result < 0)
2213         RETPUSHUNDEF;
2214     RETPUSHYES;
2215 }
2216
2217 PP(pp_fteowned)
2218 {
2219     return pp_ftrowned(ARGS);
2220 }
2221
2222 PP(pp_ftrowned)
2223 {
2224     I32 result = my_stat(ARGS);
2225     dSP;
2226     if (result < 0)
2227         RETPUSHUNDEF;
2228     if (statcache.st_uid == (op->op_type == OP_FTEOWNED ? euid : uid) )
2229         RETPUSHYES;
2230     RETPUSHNO;
2231 }
2232
2233 PP(pp_ftzero)
2234 {
2235     I32 result = my_stat(ARGS);
2236     dSP;
2237     if (result < 0)
2238         RETPUSHUNDEF;
2239     if (!statcache.st_size)
2240         RETPUSHYES;
2241     RETPUSHNO;
2242 }
2243
2244 PP(pp_ftsize)
2245 {
2246     I32 result = my_stat(ARGS);
2247     dSP; dTARGET;
2248     if (result < 0)
2249         RETPUSHUNDEF;
2250     PUSHi(statcache.st_size);
2251     RETURN;
2252 }
2253
2254 PP(pp_ftmtime)
2255 {
2256     I32 result = my_stat(ARGS);
2257     dSP; dTARGET;
2258     if (result < 0)
2259         RETPUSHUNDEF;
2260     PUSHn( ((I32)basetime - (I32)statcache.st_mtime) / 86400.0 );
2261     RETURN;
2262 }
2263
2264 PP(pp_ftatime)
2265 {
2266     I32 result = my_stat(ARGS);
2267     dSP; dTARGET;
2268     if (result < 0)
2269         RETPUSHUNDEF;
2270     PUSHn( ((I32)basetime - (I32)statcache.st_atime) / 86400.0 );
2271     RETURN;
2272 }
2273
2274 PP(pp_ftctime)
2275 {
2276     I32 result = my_stat(ARGS);
2277     dSP; dTARGET;
2278     if (result < 0)
2279         RETPUSHUNDEF;
2280     PUSHn( ((I32)basetime - (I32)statcache.st_ctime) / 86400.0 );
2281     RETURN;
2282 }
2283
2284 PP(pp_ftsock)
2285 {
2286     I32 result = my_stat(ARGS);
2287     dSP;
2288     if (result < 0)
2289         RETPUSHUNDEF;
2290     if (S_ISSOCK(statcache.st_mode))
2291         RETPUSHYES;
2292     RETPUSHNO;
2293 }
2294
2295 PP(pp_ftchr)
2296 {
2297     I32 result = my_stat(ARGS);
2298     dSP;
2299     if (result < 0)
2300         RETPUSHUNDEF;
2301     if (S_ISCHR(statcache.st_mode))
2302         RETPUSHYES;
2303     RETPUSHNO;
2304 }
2305
2306 PP(pp_ftblk)
2307 {
2308     I32 result = my_stat(ARGS);
2309     dSP;
2310     if (result < 0)
2311         RETPUSHUNDEF;
2312     if (S_ISBLK(statcache.st_mode))
2313         RETPUSHYES;
2314     RETPUSHNO;
2315 }
2316
2317 PP(pp_ftfile)
2318 {
2319     I32 result = my_stat(ARGS);
2320     dSP;
2321     if (result < 0)
2322         RETPUSHUNDEF;
2323     if (S_ISREG(statcache.st_mode))
2324         RETPUSHYES;
2325     RETPUSHNO;
2326 }
2327
2328 PP(pp_ftdir)
2329 {
2330     I32 result = my_stat(ARGS);
2331     dSP;
2332     if (result < 0)
2333         RETPUSHUNDEF;
2334     if (S_ISDIR(statcache.st_mode))
2335         RETPUSHYES;
2336     RETPUSHNO;
2337 }
2338
2339 PP(pp_ftpipe)
2340 {
2341     I32 result = my_stat(ARGS);
2342     dSP;
2343     if (result < 0)
2344         RETPUSHUNDEF;
2345     if (S_ISFIFO(statcache.st_mode))
2346         RETPUSHYES;
2347     RETPUSHNO;
2348 }
2349
2350 PP(pp_ftlink)
2351 {
2352     I32 result = my_lstat(ARGS);
2353     dSP;
2354     if (result < 0)
2355         RETPUSHUNDEF;
2356     if (S_ISLNK(statcache.st_mode))
2357         RETPUSHYES;
2358     RETPUSHNO;
2359 }
2360
2361 PP(pp_ftsuid)
2362 {
2363     dSP;
2364 #ifdef S_ISUID
2365     I32 result = my_stat(ARGS);
2366     SPAGAIN;
2367     if (result < 0)
2368         RETPUSHUNDEF;
2369     if (statcache.st_mode & S_ISUID)
2370         RETPUSHYES;
2371 #endif
2372     RETPUSHNO;
2373 }
2374
2375 PP(pp_ftsgid)
2376 {
2377     dSP;
2378 #ifdef S_ISGID
2379     I32 result = my_stat(ARGS);
2380     SPAGAIN;
2381     if (result < 0)
2382         RETPUSHUNDEF;
2383     if (statcache.st_mode & S_ISGID)
2384         RETPUSHYES;
2385 #endif
2386     RETPUSHNO;
2387 }
2388
2389 PP(pp_ftsvtx)
2390 {
2391     dSP;
2392 #ifdef S_ISVTX
2393     I32 result = my_stat(ARGS);
2394     SPAGAIN;
2395     if (result < 0)
2396         RETPUSHUNDEF;
2397     if (statcache.st_mode & S_ISVTX)
2398         RETPUSHYES;
2399 #endif
2400     RETPUSHNO;
2401 }
2402
2403 PP(pp_fttty)
2404 {
2405     dSP;
2406     int fd;
2407     GV *gv;
2408     char *tmps = Nullch;
2409
2410     if (op->op_flags & OPf_REF)
2411         gv = cGVOP->op_gv;
2412     else if (isGV(TOPs))
2413         gv = (GV*)POPs;
2414     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2415         gv = (GV*)SvRV(POPs);
2416     else
2417         gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
2418
2419     if (GvIO(gv) && IoIFP(GvIOp(gv)))
2420         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
2421     else if (tmps && isDIGIT(*tmps))
2422         fd = atoi(tmps);
2423     else
2424         RETPUSHUNDEF;
2425     if (isatty(fd))
2426         RETPUSHYES;
2427     RETPUSHNO;
2428 }
2429
2430 #if defined(atarist) /* this will work with atariST. Configure will
2431                         make guesses for other systems. */
2432 # define FILE_base(f) ((f)->_base)
2433 # define FILE_ptr(f) ((f)->_ptr)
2434 # define FILE_cnt(f) ((f)->_cnt)
2435 # define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
2436 #endif
2437
2438 PP(pp_fttext)
2439 {
2440     dSP;
2441     I32 i;
2442     I32 len;
2443     I32 odd = 0;
2444     STDCHAR tbuf[512];
2445     register STDCHAR *s;
2446     register IO *io;
2447     register SV *sv;
2448     GV *gv;
2449
2450     if (op->op_flags & OPf_REF)
2451         gv = cGVOP->op_gv;
2452     else if (isGV(TOPs))
2453         gv = (GV*)POPs;
2454     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2455         gv = (GV*)SvRV(POPs);
2456     else
2457         gv = Nullgv;
2458
2459     if (gv) {
2460         EXTEND(SP, 1);
2461         if (gv == defgv) {
2462             if (statgv)
2463                 io = GvIO(statgv);
2464             else {
2465                 sv = statname;
2466                 goto really_filename;
2467             }
2468         }
2469         else {
2470             statgv = gv;
2471             laststatval = -1;
2472             sv_setpv(statname, "");
2473             io = GvIO(statgv);
2474         }
2475         if (io && IoIFP(io)) {
2476             if (! PerlIO_has_base(IoIFP(io)))
2477                 DIE("-T and -B not implemented on filehandles");
2478             laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
2479             if (laststatval < 0)
2480                 RETPUSHUNDEF;
2481             if (S_ISDIR(statcache.st_mode))     /* handle NFS glitch */
2482                 if (op->op_type == OP_FTTEXT)
2483                     RETPUSHNO;
2484                 else
2485                     RETPUSHYES;
2486             if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2487                 i = PerlIO_getc(IoIFP(io));
2488                 if (i != EOF)
2489                     (void)PerlIO_ungetc(IoIFP(io),i);
2490             }
2491             if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
2492                 RETPUSHYES;
2493             len = PerlIO_get_bufsiz(IoIFP(io));
2494             s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2495             /* sfio can have large buffers - limit to 512 */
2496             if (len > 512)
2497                 len = 512;
2498         }
2499         else {
2500             if (dowarn)
2501                 warn("Test on unopened file <%s>",
2502                   GvENAME(cGVOP->op_gv));
2503             SETERRNO(EBADF,RMS$_IFI);
2504             RETPUSHUNDEF;
2505         }
2506     }
2507     else {
2508         sv = POPs;
2509       really_filename:
2510         statgv = Nullgv;
2511         laststatval = -1;
2512         sv_setpv(statname, SvPV(sv, na));
2513 #ifdef HAS_OPEN3
2514         i = open(SvPV(sv, na), O_RDONLY, 0);
2515 #else
2516         i = open(SvPV(sv, na), 0);
2517 #endif
2518         if (i < 0) {
2519             if (dowarn && strchr(SvPV(sv, na), '\n'))
2520                 warn(warn_nl, "open");
2521             RETPUSHUNDEF;
2522         }
2523         laststatval = Fstat(i, &statcache);
2524         if (laststatval < 0)
2525             RETPUSHUNDEF;
2526         len = read(i, tbuf, 512);
2527         (void)close(i);
2528         if (len <= 0) {
2529             if (S_ISDIR(statcache.st_mode) && op->op_type == OP_FTTEXT)
2530                 RETPUSHNO;              /* special case NFS directories */
2531             RETPUSHYES;         /* null file is anything */
2532         }
2533         s = tbuf;
2534     }
2535
2536     /* now scan s to look for textiness */
2537     /*   XXX ASCII dependent code */
2538
2539     for (i = 0; i < len; i++, s++) {
2540         if (!*s) {                      /* null never allowed in text */
2541             odd += len;
2542             break;
2543         }
2544         else if (*s & 128)
2545             odd++;
2546         else if (*s < 32 &&
2547           *s != '\n' && *s != '\r' && *s != '\b' &&
2548           *s != '\t' && *s != '\f' && *s != 27)
2549             odd++;
2550     }
2551
2552     if ((odd * 3 > len) == (op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
2553         RETPUSHNO;
2554     else
2555         RETPUSHYES;
2556 }
2557
2558 PP(pp_ftbinary)
2559 {
2560     return pp_fttext(ARGS);
2561 }
2562
2563 /* File calls. */
2564
2565 PP(pp_chdir)
2566 {
2567     dSP; dTARGET;
2568     char *tmps;
2569     SV **svp;
2570
2571     if (MAXARG < 1)
2572         tmps = Nullch;
2573     else
2574         tmps = POPp;
2575     if (!tmps || !*tmps) {
2576         svp = hv_fetch(GvHVn(envgv), "HOME", 4, FALSE);
2577         if (svp)
2578             tmps = SvPV(*svp, na);
2579     }
2580     if (!tmps || !*tmps) {
2581         svp = hv_fetch(GvHVn(envgv), "LOGDIR", 6, FALSE);
2582         if (svp)
2583             tmps = SvPV(*svp, na);
2584     }
2585     TAINT_PROPER("chdir");
2586     PUSHi( chdir(tmps) >= 0 );
2587 #ifdef VMS
2588     /* Clear the DEFAULT element of ENV so we'll get the new value
2589      * in the future. */
2590     hv_delete(GvHVn(envgv),"DEFAULT",7,G_DISCARD);
2591 #endif
2592     RETURN;
2593 }
2594
2595 PP(pp_chown)
2596 {
2597     dSP; dMARK; dTARGET;
2598     I32 value;
2599 #ifdef HAS_CHOWN
2600     value = (I32)apply(op->op_type, MARK, SP);
2601     SP = MARK;
2602     PUSHi(value);
2603     RETURN;
2604 #else
2605     DIE(no_func, "Unsupported function chown");
2606 #endif
2607 }
2608
2609 PP(pp_chroot)
2610 {
2611     dSP; dTARGET;
2612     char *tmps;
2613 #ifdef HAS_CHROOT
2614     tmps = POPp;
2615     TAINT_PROPER("chroot");
2616     PUSHi( chroot(tmps) >= 0 );
2617     RETURN;
2618 #else
2619     DIE(no_func, "chroot");
2620 #endif
2621 }
2622
2623 PP(pp_unlink)
2624 {
2625     dSP; dMARK; dTARGET;
2626     I32 value;
2627     value = (I32)apply(op->op_type, MARK, SP);
2628     SP = MARK;
2629     PUSHi(value);
2630     RETURN;
2631 }
2632
2633 PP(pp_chmod)
2634 {
2635     dSP; dMARK; dTARGET;
2636     I32 value;
2637     value = (I32)apply(op->op_type, MARK, SP);
2638     SP = MARK;
2639     PUSHi(value);
2640     RETURN;
2641 }
2642
2643 PP(pp_utime)
2644 {
2645     dSP; dMARK; dTARGET;
2646     I32 value;
2647     value = (I32)apply(op->op_type, MARK, SP);
2648     SP = MARK;
2649     PUSHi(value);
2650     RETURN;
2651 }
2652
2653 PP(pp_rename)
2654 {
2655     dSP; dTARGET;
2656     int anum;
2657
2658     char *tmps2 = POPp;
2659     char *tmps = SvPV(TOPs, na);
2660     TAINT_PROPER("rename");
2661 #ifdef HAS_RENAME
2662     anum = rename(tmps, tmps2);
2663 #else
2664     if (!(anum = Stat(tmps, &statbuf))) {
2665         if (same_dirent(tmps2, tmps))   /* can always rename to same name */
2666             anum = 1;
2667         else {
2668             if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
2669                 (void)UNLINK(tmps2);
2670             if (!(anum = link(tmps, tmps2)))
2671                 anum = UNLINK(tmps);
2672         }
2673     }
2674 #endif
2675     SETi( anum >= 0 );
2676     RETURN;
2677 }
2678
2679 PP(pp_link)
2680 {
2681     dSP; dTARGET;
2682 #ifdef HAS_LINK
2683     char *tmps2 = POPp;
2684     char *tmps = SvPV(TOPs, na);
2685     TAINT_PROPER("link");
2686     SETi( link(tmps, tmps2) >= 0 );
2687 #else
2688     DIE(no_func, "Unsupported function link");
2689 #endif
2690     RETURN;
2691 }
2692
2693 PP(pp_symlink)
2694 {
2695     dSP; dTARGET;
2696 #ifdef HAS_SYMLINK
2697     char *tmps2 = POPp;
2698     char *tmps = SvPV(TOPs, na);
2699     TAINT_PROPER("symlink");
2700     SETi( symlink(tmps, tmps2) >= 0 );
2701     RETURN;
2702 #else
2703     DIE(no_func, "symlink");
2704 #endif
2705 }
2706
2707 PP(pp_readlink)
2708 {
2709     dSP; dTARGET;
2710 #ifdef HAS_SYMLINK
2711     char *tmps;
2712     char buf[MAXPATHLEN];
2713     int len;
2714
2715 #ifndef INCOMPLETE_TAINTS
2716     TAINT;
2717 #endif
2718     tmps = POPp;
2719     len = readlink(tmps, buf, sizeof buf);
2720     EXTEND(SP, 1);
2721     if (len < 0)
2722         RETPUSHUNDEF;
2723     PUSHp(buf, len);
2724     RETURN;
2725 #else
2726     EXTEND(SP, 1);
2727     RETSETUNDEF;                /* just pretend it's a normal file */
2728 #endif
2729 }
2730
2731 #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
2732 static int
2733 dooneliner(cmd, filename)
2734 char *cmd;
2735 char *filename;
2736 {
2737     char *save_filename = filename;
2738     char *cmdline;
2739     char *s;
2740     PerlIO *myfp;
2741     int anum = 1;
2742
2743     New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
2744     strcpy(cmdline, cmd);
2745     strcat(cmdline, " ");
2746     for (s = cmdline + strlen(cmdline); *filename; ) {
2747         *s++ = '\\';
2748         *s++ = *filename++;
2749     }
2750     strcpy(s, " 2>&1");
2751     myfp = my_popen(cmdline, "r");
2752     Safefree(cmdline);
2753
2754     if (myfp) {
2755         SV *tmpsv = sv_newmortal();
2756         /* Need to save/restore 'rs' ?? */
2757         s = sv_gets(tmpsv, myfp, 0);
2758         (void)my_pclose(myfp);
2759         if (s != Nullch) {
2760             int e;
2761             for (e = 1;
2762 #ifdef HAS_SYS_ERRLIST
2763                  e <= sys_nerr
2764 #endif
2765                  ; e++)
2766             {
2767                 /* you don't see this */
2768                 char *errmsg =
2769 #ifdef HAS_SYS_ERRLIST
2770                     sys_errlist[e]
2771 #else
2772                     strerror(e)
2773 #endif
2774                     ;
2775                 if (!errmsg)
2776                     break;
2777                 if (instr(s, errmsg)) {
2778                     SETERRNO(e,0);
2779                     return 0;
2780                 }
2781             }
2782             SETERRNO(0,0);
2783 #ifndef EACCES
2784 #define EACCES EPERM
2785 #endif
2786             if (instr(s, "cannot make"))
2787                 SETERRNO(EEXIST,RMS$_FEX);
2788             else if (instr(s, "existing file"))
2789                 SETERRNO(EEXIST,RMS$_FEX);
2790             else if (instr(s, "ile exists"))
2791                 SETERRNO(EEXIST,RMS$_FEX);
2792             else if (instr(s, "non-exist"))
2793                 SETERRNO(ENOENT,RMS$_FNF);
2794             else if (instr(s, "does not exist"))
2795                 SETERRNO(ENOENT,RMS$_FNF);
2796             else if (instr(s, "not empty"))
2797                 SETERRNO(EBUSY,SS$_DEVOFFLINE);
2798             else if (instr(s, "cannot access"))
2799                 SETERRNO(EACCES,RMS$_PRV);
2800             else
2801                 SETERRNO(EPERM,RMS$_PRV);
2802             return 0;
2803         }
2804         else {  /* some mkdirs return no failure indication */
2805             anum = (Stat(save_filename, &statbuf) >= 0);
2806             if (op->op_type == OP_RMDIR)
2807                 anum = !anum;
2808             if (anum)
2809                 SETERRNO(0,0);
2810             else
2811                 SETERRNO(EACCES,RMS$_PRV);      /* a guess */
2812         }
2813         return anum;
2814     }
2815     else
2816         return 0;
2817 }
2818 #endif
2819
2820 PP(pp_mkdir)
2821 {
2822     dSP; dTARGET;
2823     int mode = POPi;
2824 #ifndef HAS_MKDIR
2825     int oldumask;
2826 #endif
2827     char *tmps = SvPV(TOPs, na);
2828
2829     TAINT_PROPER("mkdir");
2830 #ifdef HAS_MKDIR
2831     SETi( Mkdir(tmps, mode) >= 0 );
2832 #else
2833     SETi( dooneliner("mkdir", tmps) );
2834     oldumask = umask(0);
2835     umask(oldumask);
2836     chmod(tmps, (mode & ~oldumask) & 0777);
2837 #endif
2838     RETURN;
2839 }
2840
2841 PP(pp_rmdir)
2842 {
2843     dSP; dTARGET;
2844     char *tmps;
2845
2846     tmps = POPp;
2847     TAINT_PROPER("rmdir");
2848 #ifdef HAS_RMDIR
2849     XPUSHi( rmdir(tmps) >= 0 );
2850 #else
2851     XPUSHi( dooneliner("rmdir", tmps) );
2852 #endif
2853     RETURN;
2854 }
2855
2856 /* Directory calls. */
2857
2858 PP(pp_open_dir)
2859 {
2860     dSP;
2861 #if defined(Direntry_t) && defined(HAS_READDIR)
2862     char *dirname = POPp;
2863     GV *gv = (GV*)POPs;
2864     register IO *io = GvIOn(gv);
2865
2866     if (!io)
2867         goto nope;
2868
2869     if (IoDIRP(io))
2870         closedir(IoDIRP(io));
2871     if (!(IoDIRP(io) = opendir(dirname)))
2872         goto nope;
2873
2874     RETPUSHYES;
2875 nope:
2876     if (!errno)
2877         SETERRNO(EBADF,RMS$_DIR);
2878     RETPUSHUNDEF;
2879 #else
2880     DIE(no_dir_func, "opendir");
2881 #endif
2882 }
2883
2884 PP(pp_readdir)
2885 {
2886     dSP;
2887 #if defined(Direntry_t) && defined(HAS_READDIR)
2888 #ifndef I_DIRENT
2889     Direntry_t *readdir _((DIR *));
2890 #endif
2891     register Direntry_t *dp;
2892     GV *gv = (GV*)POPs;
2893     register IO *io = GvIOn(gv);
2894     SV *sv;
2895
2896     if (!io || !IoDIRP(io))
2897         goto nope;
2898
2899     if (GIMME == G_ARRAY) {
2900         /*SUPPRESS 560*/
2901         while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
2902 #ifdef DIRNAMLEN
2903             sv = newSVpv(dp->d_name, dp->d_namlen);
2904 #else
2905             sv = newSVpv(dp->d_name, 0);
2906 #endif
2907 #ifndef INCOMPLETE_TAINTS
2908             SvTAINTED_on(sv);
2909 #endif
2910             XPUSHs(sv_2mortal(sv));
2911         }
2912     }
2913     else {
2914         if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
2915             goto nope;
2916 #ifdef DIRNAMLEN
2917         sv = newSVpv(dp->d_name, dp->d_namlen);
2918 #else
2919         sv = newSVpv(dp->d_name, 0);
2920 #endif
2921 #ifndef INCOMPLETE_TAINTS
2922         SvTAINTED_on(sv);
2923 #endif
2924         XPUSHs(sv_2mortal(sv));
2925     }
2926     RETURN;
2927
2928 nope:
2929     if (!errno)
2930         SETERRNO(EBADF,RMS$_ISI);
2931     if (GIMME == G_ARRAY)
2932         RETURN;
2933     else
2934         RETPUSHUNDEF;
2935 #else
2936     DIE(no_dir_func, "readdir");
2937 #endif
2938 }
2939
2940 PP(pp_telldir)
2941 {
2942     dSP; dTARGET;
2943 #if defined(HAS_TELLDIR) || defined(telldir)
2944 #if !defined(telldir) && !defined(HAS_TELLDIR_PROTOTYPE) && !defined(DONT_DECLARE_STD)
2945     long telldir _((DIR *));
2946 #endif
2947     GV *gv = (GV*)POPs;
2948     register IO *io = GvIOn(gv);
2949
2950     if (!io || !IoDIRP(io))
2951         goto nope;
2952
2953     PUSHi( telldir(IoDIRP(io)) );
2954     RETURN;
2955 nope:
2956     if (!errno)
2957         SETERRNO(EBADF,RMS$_ISI);
2958     RETPUSHUNDEF;
2959 #else
2960     DIE(no_dir_func, "telldir");
2961 #endif
2962 }
2963
2964 PP(pp_seekdir)
2965 {
2966     dSP;
2967 #if defined(HAS_SEEKDIR) || defined(seekdir)
2968     long along = POPl;
2969     GV *gv = (GV*)POPs;
2970     register IO *io = GvIOn(gv);
2971
2972     if (!io || !IoDIRP(io))
2973         goto nope;
2974
2975     (void)seekdir(IoDIRP(io), along);
2976
2977     RETPUSHYES;
2978 nope:
2979     if (!errno)
2980         SETERRNO(EBADF,RMS$_ISI);
2981     RETPUSHUNDEF;
2982 #else
2983     DIE(no_dir_func, "seekdir");
2984 #endif
2985 }
2986
2987 PP(pp_rewinddir)
2988 {
2989     dSP;
2990 #if defined(HAS_REWINDDIR) || defined(rewinddir)
2991     GV *gv = (GV*)POPs;
2992     register IO *io = GvIOn(gv);
2993
2994     if (!io || !IoDIRP(io))
2995         goto nope;
2996
2997     (void)rewinddir(IoDIRP(io));
2998     RETPUSHYES;
2999 nope:
3000     if (!errno)
3001         SETERRNO(EBADF,RMS$_ISI);
3002     RETPUSHUNDEF;
3003 #else
3004     DIE(no_dir_func, "rewinddir");
3005 #endif
3006 }
3007
3008 PP(pp_closedir)
3009 {
3010     dSP;
3011 #if defined(Direntry_t) && defined(HAS_READDIR)
3012     GV *gv = (GV*)POPs;
3013     register IO *io = GvIOn(gv);
3014
3015     if (!io || !IoDIRP(io))
3016         goto nope;
3017
3018 #ifdef VOID_CLOSEDIR
3019     closedir(IoDIRP(io));
3020 #else
3021     if (closedir(IoDIRP(io)) < 0) {
3022         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3023         goto nope;
3024     }
3025 #endif
3026     IoDIRP(io) = 0;
3027
3028     RETPUSHYES;
3029 nope:
3030     if (!errno)
3031         SETERRNO(EBADF,RMS$_IFI);
3032     RETPUSHUNDEF;
3033 #else
3034     DIE(no_dir_func, "closedir");
3035 #endif
3036 }
3037
3038 /* Process control. */
3039
3040 PP(pp_fork)
3041 {
3042 #ifdef HAS_FORK
3043     dSP; dTARGET;
3044     int childpid;
3045     GV *tmpgv;
3046
3047     EXTEND(SP, 1);
3048     childpid = fork();
3049     if (childpid < 0)
3050         RETSETUNDEF;
3051     if (!childpid) {
3052         /*SUPPRESS 560*/
3053         if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
3054             sv_setiv(GvSV(tmpgv), (IV)getpid());
3055         hv_clear(pidstatus);    /* no kids, so don't wait for 'em */
3056     }
3057     PUSHi(childpid);
3058     RETURN;
3059 #else
3060     DIE(no_func, "Unsupported function fork");
3061 #endif
3062 }
3063
3064 PP(pp_wait)
3065 {
3066 #if !defined(DOSISH) || defined(OS2)
3067     dSP; dTARGET;
3068     int childpid;
3069     int argflags;
3070
3071     childpid = wait4pid(-1, &argflags, 0);
3072     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3073     XPUSHi(childpid);
3074     RETURN;
3075 #else
3076     DIE(no_func, "Unsupported function wait");
3077 #endif
3078 }
3079
3080 PP(pp_waitpid)
3081 {
3082 #if !defined(DOSISH) || defined(OS2)
3083     dSP; dTARGET;
3084     int childpid;
3085     int optype;
3086     int argflags;
3087
3088     optype = POPi;
3089     childpid = TOPi;
3090     childpid = wait4pid(childpid, &argflags, optype);
3091     STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
3092     SETi(childpid);
3093     RETURN;
3094 #else
3095     DIE(no_func, "Unsupported function wait");
3096 #endif
3097 }
3098
3099 PP(pp_system)
3100 {
3101     dSP; dMARK; dORIGMARK; dTARGET;
3102     I32 value;
3103     int childpid;
3104     int result;
3105     int status;
3106     Sigsave_t ihand,qhand;     /* place to save signals during system() */
3107
3108     if (SP - MARK == 1) {
3109         if (tainting) {
3110             char *junk = SvPV(TOPs, na);
3111             TAINT_ENV();
3112             TAINT_PROPER("system");
3113         }
3114     }
3115 #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
3116     while ((childpid = vfork()) == -1) {
3117         if (errno != EAGAIN) {
3118             value = -1;
3119             SP = ORIGMARK;
3120             PUSHi(value);
3121             RETURN;
3122         }
3123         sleep(5);
3124     }
3125     if (childpid > 0) {
3126         rsignal_save(SIGINT, SIG_IGN, &ihand);
3127         rsignal_save(SIGQUIT, SIG_IGN, &qhand);
3128         do {
3129             result = wait4pid(childpid, &status, 0);
3130         } while (result == -1 && errno == EINTR);
3131         (void)rsignal_restore(SIGINT, &ihand);
3132         (void)rsignal_restore(SIGQUIT, &qhand);
3133         STATUS_NATIVE_SET(result == -1 ? -1 : status);
3134         do_execfree();  /* free any memory child malloced on vfork */
3135         SP = ORIGMARK;
3136         PUSHi(STATUS_CURRENT);
3137         RETURN;
3138     }
3139     if (op->op_flags & OPf_STACKED) {
3140         SV *really = *++MARK;
3141         value = (I32)do_aexec(really, MARK, SP);
3142     }
3143     else if (SP - MARK != 1)
3144         value = (I32)do_aexec(Nullsv, MARK, SP);
3145     else {
3146         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3147     }
3148     _exit(-1);
3149 #else /* ! FORK or VMS or OS/2 */
3150     if (op->op_flags & OPf_STACKED) {
3151         SV *really = *++MARK;
3152         value = (I32)do_aspawn(really, MARK, SP);
3153     }
3154     else if (SP - MARK != 1)
3155         value = (I32)do_aspawn(Nullsv, MARK, SP);
3156     else {
3157         value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
3158     }
3159     STATUS_NATIVE_SET(value);
3160     do_execfree();
3161     SP = ORIGMARK;
3162     PUSHi(STATUS_CURRENT);
3163 #endif /* !FORK or VMS */
3164     RETURN;
3165 }
3166
3167 PP(pp_exec)
3168 {
3169     dSP; dMARK; dORIGMARK; dTARGET;
3170     I32 value;
3171
3172     if (op->op_flags & OPf_STACKED) {
3173         SV *really = *++MARK;
3174         value = (I32)do_aexec(really, MARK, SP);
3175     }
3176     else if (SP - MARK != 1)
3177 #ifdef VMS
3178         value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3179 #else
3180         value = (I32)do_aexec(Nullsv, MARK, SP);
3181 #endif
3182     else {
3183         if (tainting) {
3184             char *junk = SvPV(*SP, na);
3185             TAINT_ENV();
3186             TAINT_PROPER("exec");
3187         }
3188 #ifdef VMS
3189         value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), na));
3190 #else
3191         value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), na));
3192 #endif
3193     }
3194     SP = ORIGMARK;
3195     PUSHi(value);
3196     RETURN;
3197 }
3198
3199 PP(pp_kill)
3200 {
3201     dSP; dMARK; dTARGET;
3202     I32 value;
3203 #ifdef HAS_KILL
3204     value = (I32)apply(op->op_type, MARK, SP);
3205     SP = MARK;
3206     PUSHi(value);
3207     RETURN;
3208 #else
3209     DIE(no_func, "Unsupported function kill");
3210 #endif
3211 }
3212
3213 PP(pp_getppid)
3214 {
3215 #ifdef HAS_GETPPID
3216     dSP; dTARGET;
3217     XPUSHi( getppid() );
3218     RETURN;
3219 #else
3220     DIE(no_func, "getppid");
3221 #endif
3222 }
3223
3224 PP(pp_getpgrp)
3225 {
3226 #ifdef HAS_GETPGRP
3227     dSP; dTARGET;
3228     int pid;
3229     I32 value;
3230
3231     if (MAXARG < 1)
3232         pid = 0;
3233     else
3234         pid = SvIVx(POPs);
3235 #ifdef BSD_GETPGRP
3236     value = (I32)BSD_GETPGRP(pid);
3237 #else
3238     if (pid != 0 && pid != getpid())
3239         DIE("POSIX getpgrp can't take an argument");
3240     value = (I32)getpgrp();
3241 #endif
3242     XPUSHi(value);
3243     RETURN;
3244 #else
3245     DIE(no_func, "getpgrp()");
3246 #endif
3247 }
3248
3249 PP(pp_setpgrp)
3250 {
3251 #ifdef HAS_SETPGRP
3252     dSP; dTARGET;
3253     int pgrp;
3254     int pid;
3255     if (MAXARG < 2) {
3256         pgrp = 0;
3257         pid = 0;
3258     }
3259     else {
3260         pgrp = POPi;
3261         pid = TOPi;
3262     }
3263
3264     TAINT_PROPER("setpgrp");
3265 #ifdef BSD_SETPGRP
3266     SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
3267 #else
3268     if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
3269         DIE("POSIX setpgrp can't take an argument");
3270     SETi( setpgrp() >= 0 );
3271 #endif /* USE_BSDPGRP */
3272     RETURN;
3273 #else
3274     DIE(no_func, "setpgrp()");
3275 #endif
3276 }
3277
3278 PP(pp_getpriority)
3279 {
3280     dSP; dTARGET;
3281     int which;
3282     int who;
3283 #ifdef HAS_GETPRIORITY
3284     who = POPi;
3285     which = TOPi;
3286     SETi( getpriority(which, who) );
3287     RETURN;
3288 #else
3289     DIE(no_func, "getpriority()");
3290 #endif
3291 }
3292
3293 PP(pp_setpriority)
3294 {
3295     dSP; dTARGET;
3296     int which;
3297     int who;
3298     int niceval;
3299 #ifdef HAS_SETPRIORITY
3300     niceval = POPi;
3301     who = POPi;
3302     which = TOPi;
3303     TAINT_PROPER("setpriority");
3304     SETi( setpriority(which, who, niceval) >= 0 );
3305     RETURN;
3306 #else
3307     DIE(no_func, "setpriority()");
3308 #endif
3309 }
3310
3311 /* Time calls. */
3312
3313 PP(pp_time)
3314 {
3315     dSP; dTARGET;
3316 #ifdef BIG_TIME
3317     XPUSHn( time(Null(Time_t*)) );
3318 #else
3319     XPUSHi( time(Null(Time_t*)) );
3320 #endif
3321     RETURN;
3322 }
3323
3324 /* XXX The POSIX name is CLK_TCK; it is to be preferred
3325    to HZ.  Probably.  For now, assume that if the system
3326    defines HZ, it does so correctly.  (Will this break
3327    on VMS?)
3328    Probably we ought to use _sysconf(_SC_CLK_TCK), if
3329    it's supported.    --AD  9/96.
3330 */
3331
3332 #ifndef HZ
3333 #  ifdef CLK_TCK
3334 #    define HZ CLK_TCK
3335 #  else
3336 #    define HZ 60
3337 #  endif
3338 #endif
3339
3340 PP(pp_tms)
3341 {
3342     dSP;
3343
3344 #ifndef HAS_TIMES
3345     DIE("times not implemented");
3346 #else
3347     EXTEND(SP, 4);
3348
3349 #ifndef VMS
3350     (void)times(&timesbuf);
3351 #else
3352     (void)times((tbuffer_t *)&timesbuf);  /* time.h uses different name for */
3353                                           /* struct tms, though same data   */
3354                                           /* is returned.                   */
3355 #endif
3356
3357     PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
3358     if (GIMME == G_ARRAY) {
3359         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_stime)/HZ)));
3360         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cutime)/HZ)));
3361         PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
3362     }
3363     RETURN;
3364 #endif /* HAS_TIMES */
3365 }
3366
3367 PP(pp_localtime)
3368 {
3369     return pp_gmtime(ARGS);
3370 }
3371
3372 PP(pp_gmtime)
3373 {
3374     dSP;
3375     Time_t when;
3376     struct tm *tmbuf;
3377     static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3378     static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3379                               "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3380
3381     if (MAXARG < 1)
3382         (void)time(&when);
3383     else
3384 #ifdef BIG_TIME
3385         when = (Time_t)SvNVx(POPs);
3386 #else
3387         when = (Time_t)SvIVx(POPs);
3388 #endif
3389
3390     if (op->op_type == OP_LOCALTIME)
3391         tmbuf = localtime(&when);
3392     else
3393         tmbuf = gmtime(&when);
3394
3395     EXTEND(SP, 9);
3396     EXTEND_MORTAL(9);
3397     if (GIMME != G_ARRAY) {
3398         dTARGET;
3399         SV *tsv;
3400         if (!tmbuf)
3401             RETPUSHUNDEF;
3402         tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3403                        dayname[tmbuf->tm_wday],
3404                        monname[tmbuf->tm_mon],
3405                        tmbuf->tm_mday,
3406                        tmbuf->tm_hour,
3407                        tmbuf->tm_min,
3408                        tmbuf->tm_sec,
3409                        tmbuf->tm_year + 1900);
3410         PUSHs(sv_2mortal(tsv));
3411     }
3412     else if (tmbuf) {
3413         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3414         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3415         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3416         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3417         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3418         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3419         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3420         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3421         PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3422     }
3423     RETURN;
3424 }
3425
3426 PP(pp_alarm)
3427 {
3428     dSP; dTARGET;
3429     int anum;
3430 #ifdef HAS_ALARM
3431     anum = POPi;
3432     anum = alarm((unsigned int)anum);
3433     EXTEND(SP, 1);
3434     if (anum < 0)
3435         RETPUSHUNDEF;
3436     PUSHi((I32)anum);
3437     RETURN;
3438 #else
3439     DIE(no_func, "Unsupported function alarm");
3440 #endif
3441 }
3442
3443 PP(pp_sleep)
3444 {
3445     dSP; dTARGET;
3446     I32 duration;
3447     Time_t lasttime;
3448     Time_t when;
3449
3450     (void)time(&lasttime);
3451     if (MAXARG < 1)
3452         Pause();
3453     else {
3454         duration = POPi;
3455         sleep((unsigned int)duration);
3456     }
3457     (void)time(&when);
3458     XPUSHi(when - lasttime);
3459     RETURN;
3460 }
3461
3462 /* Shared memory. */
3463
3464 PP(pp_shmget)
3465 {
3466     return pp_semget(ARGS);
3467 }
3468
3469 PP(pp_shmctl)
3470 {
3471     return pp_semctl(ARGS);
3472 }
3473
3474 PP(pp_shmread)
3475 {
3476     return pp_shmwrite(ARGS);
3477 }
3478
3479 PP(pp_shmwrite)
3480 {
3481 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3482     dSP; dMARK; dTARGET;
3483     I32 value = (I32)(do_shmio(op->op_type, MARK, SP) >= 0);
3484     SP = MARK;
3485     PUSHi(value);
3486     RETURN;
3487 #else
3488     return pp_semget(ARGS);
3489 #endif
3490 }
3491
3492 /* Message passing. */
3493
3494 PP(pp_msgget)
3495 {
3496     return pp_semget(ARGS);
3497 }
3498
3499 PP(pp_msgctl)
3500 {
3501     return pp_semctl(ARGS);
3502 }
3503
3504 PP(pp_msgsnd)
3505 {
3506 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3507     dSP; dMARK; dTARGET;
3508     I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3509     SP = MARK;
3510     PUSHi(value);
3511     RETURN;
3512 #else
3513     return pp_semget(ARGS);
3514 #endif
3515 }
3516
3517 PP(pp_msgrcv)
3518 {
3519 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3520     dSP; dMARK; dTARGET;
3521     I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3522     SP = MARK;
3523     PUSHi(value);
3524     RETURN;
3525 #else
3526     return pp_semget(ARGS);
3527 #endif
3528 }
3529
3530 /* Semaphores. */
3531
3532 PP(pp_semget)
3533 {
3534 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3535     dSP; dMARK; dTARGET;
3536     int anum = do_ipcget(op->op_type, MARK, SP);
3537     SP = MARK;
3538     if (anum == -1)
3539         RETPUSHUNDEF;
3540     PUSHi(anum);
3541     RETURN;
3542 #else
3543     DIE("System V IPC is not implemented on this machine");
3544 #endif
3545 }
3546
3547 PP(pp_semctl)
3548 {
3549 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3550     dSP; dMARK; dTARGET;
3551     int anum = do_ipcctl(op->op_type, MARK, SP);
3552     SP = MARK;
3553     if (anum == -1)
3554         RETSETUNDEF;
3555     if (anum != 0) {
3556         PUSHi(anum);
3557     }
3558     else {
3559         PUSHp(zero_but_true, ZBTLEN);
3560     }
3561     RETURN;
3562 #else
3563     return pp_semget(ARGS);
3564 #endif
3565 }
3566
3567 PP(pp_semop)
3568 {
3569 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
3570     dSP; dMARK; dTARGET;
3571     I32 value = (I32)(do_semop(MARK, SP) >= 0);
3572     SP = MARK;
3573     PUSHi(value);
3574     RETURN;
3575 #else
3576     return pp_semget(ARGS);
3577 #endif
3578 }
3579
3580 /* Get system info. */
3581
3582 PP(pp_ghbyname)
3583 {
3584 #ifdef HAS_SOCKET
3585     return pp_ghostent(ARGS);
3586 #else
3587     DIE(no_sock_func, "gethostbyname");
3588 #endif
3589 }
3590
3591 PP(pp_ghbyaddr)
3592 {
3593 #ifdef HAS_SOCKET
3594     return pp_ghostent(ARGS);
3595 #else
3596     DIE(no_sock_func, "gethostbyaddr");
3597 #endif
3598 }
3599
3600 PP(pp_ghostent)
3601 {
3602     dSP;
3603 #ifdef HAS_SOCKET
3604     I32 which = op->op_type;
3605     register char **elem;
3606     register SV *sv;
3607 #if defined(HAS_GETHOSTENT) && !defined(DONT_DECLARE_STD)
3608     struct hostent *gethostbyname(const char *);
3609     struct hostent *gethostbyaddr(const char *, int, int);
3610     struct hostent *gethostent(void);
3611 #endif
3612     struct hostent *hent;
3613     unsigned long len;
3614
3615     EXTEND(SP, 10);
3616     if (which == OP_GHBYNAME) {
3617         hent = gethostbyname(POPp);
3618     }
3619     else if (which == OP_GHBYADDR) {
3620         int addrtype = POPi;
3621         SV *addrsv = POPs;
3622         STRLEN addrlen;
3623         char *addr = SvPV(addrsv, addrlen);
3624
3625         hent = gethostbyaddr(addr, addrlen, addrtype);
3626     }
3627     else
3628 #ifdef HAS_GETHOSTENT
3629         hent = gethostent();
3630 #else
3631         DIE("gethostent not implemented");
3632 #endif
3633
3634 #ifdef HOST_NOT_FOUND
3635     if (!hent)
3636         STATUS_NATIVE_SET(h_errno);
3637 #endif
3638
3639     if (GIMME != G_ARRAY) {
3640         PUSHs(sv = sv_newmortal());
3641         if (hent) {
3642             if (which == OP_GHBYNAME) {
3643                 if (hent->h_addr)
3644                     sv_setpvn(sv, hent->h_addr, hent->h_length);
3645             }
3646             else
3647                 sv_setpv(sv, (char*)hent->h_name);
3648         }
3649         RETURN;
3650     }
3651
3652     if (hent) {
3653         PUSHs(sv = sv_mortalcopy(&sv_no));
3654         sv_setpv(sv, (char*)hent->h_name);
3655         PUSHs(sv = sv_mortalcopy(&sv_no));
3656         for (elem = hent->h_aliases; elem && *elem; elem++) {
3657             sv_catpv(sv, *elem);
3658             if (elem[1])
3659                 sv_catpvn(sv, " ", 1);
3660         }
3661         PUSHs(sv = sv_mortalcopy(&sv_no));
3662         sv_setiv(sv, (IV)hent->h_addrtype);
3663         PUSHs(sv = sv_mortalcopy(&sv_no));
3664         len = hent->h_length;
3665         sv_setiv(sv, (IV)len);
3666 #ifdef h_addr
3667         for (elem = hent->h_addr_list; elem && *elem; elem++) {
3668             XPUSHs(sv = sv_mortalcopy(&sv_no));
3669             sv_setpvn(sv, *elem, len);
3670         }
3671 #else
3672         PUSHs(sv = sv_mortalcopy(&sv_no));
3673         if (hent->h_addr)
3674             sv_setpvn(sv, hent->h_addr, len);
3675 #endif /* h_addr */
3676     }
3677     RETURN;
3678 #else
3679     DIE(no_sock_func, "gethostent");
3680 #endif
3681 }
3682
3683 PP(pp_gnbyname)
3684 {
3685 #ifdef HAS_SOCKET
3686     return pp_gnetent(ARGS);
3687 #else
3688     DIE(no_sock_func, "getnetbyname");
3689 #endif
3690 }
3691
3692 PP(pp_gnbyaddr)
3693 {
3694 #ifdef HAS_SOCKET
3695     return pp_gnetent(ARGS);
3696 #else
3697     DIE(no_sock_func, "getnetbyaddr");
3698 #endif
3699 }
3700
3701 PP(pp_gnetent)
3702 {
3703     dSP;
3704 #ifdef HAS_SOCKET
3705     I32 which = op->op_type;
3706     register char **elem;
3707     register SV *sv;
3708 #ifndef DONT_DECLARE_STD
3709     struct netent *getnetbyname(const char *);
3710     struct netent *getnetbyaddr(long int, int);
3711     struct netent *getnetent(void);
3712 #endif
3713     struct netent *nent;
3714
3715     if (which == OP_GNBYNAME)
3716         nent = getnetbyname(POPp);
3717     else if (which == OP_GNBYADDR) {
3718         int addrtype = POPi;
3719         unsigned long addr = U_L(POPn);
3720         nent = getnetbyaddr((long)addr, addrtype);
3721     }
3722     else
3723         nent = getnetent();
3724
3725     EXTEND(SP, 4);
3726     if (GIMME != G_ARRAY) {
3727         PUSHs(sv = sv_newmortal());
3728         if (nent) {
3729             if (which == OP_GNBYNAME)
3730                 sv_setiv(sv, (IV)nent->n_net);
3731             else
3732                 sv_setpv(sv, nent->n_name);
3733         }
3734         RETURN;
3735     }
3736
3737     if (nent) {
3738         PUSHs(sv = sv_mortalcopy(&sv_no));
3739         sv_setpv(sv, nent->n_name);
3740         PUSHs(sv = sv_mortalcopy(&sv_no));
3741         for (elem = nent->n_aliases; elem && *elem; elem++) {
3742             sv_catpv(sv, *elem);
3743             if (elem[1])
3744                 sv_catpvn(sv, " ", 1);
3745         }
3746         PUSHs(sv = sv_mortalcopy(&sv_no));
3747         sv_setiv(sv, (IV)nent->n_addrtype);
3748         PUSHs(sv = sv_mortalcopy(&sv_no));
3749         sv_setiv(sv, (IV)nent->n_net);
3750     }
3751
3752     RETURN;
3753 #else
3754     DIE(no_sock_func, "getnetent");
3755 #endif
3756 }
3757
3758 PP(pp_gpbyname)
3759 {
3760 #ifdef HAS_SOCKET
3761     return pp_gprotoent(ARGS);
3762 #else
3763     DIE(no_sock_func, "getprotobyname");
3764 #endif
3765 }
3766
3767 PP(pp_gpbynumber)
3768 {
3769 #ifdef HAS_SOCKET
3770     return pp_gprotoent(ARGS);
3771 #else
3772     DIE(no_sock_func, "getprotobynumber");
3773 #endif
3774 }
3775
3776 PP(pp_gprotoent)
3777 {
3778     dSP;
3779 #ifdef HAS_SOCKET
3780     I32 which = op->op_type;
3781     register char **elem;
3782     register SV *sv;  
3783 #ifndef DONT_DECLARE_STD
3784     struct protoent *getprotobyname(const char *);
3785     struct protoent *getprotobynumber(int);
3786     struct protoent *getprotoent(void);
3787 #endif
3788     struct protoent *pent;
3789
3790     if (which == OP_GPBYNAME)
3791         pent = getprotobyname(POPp);
3792     else if (which == OP_GPBYNUMBER)
3793         pent = getprotobynumber(POPi);
3794     else
3795         pent = getprotoent();
3796
3797     EXTEND(SP, 3);
3798     if (GIMME != G_ARRAY) {
3799         PUSHs(sv = sv_newmortal());
3800         if (pent) {
3801             if (which == OP_GPBYNAME)
3802                 sv_setiv(sv, (IV)pent->p_proto);
3803             else
3804                 sv_setpv(sv, pent->p_name);
3805         }
3806         RETURN;
3807     }
3808
3809     if (pent) {
3810         PUSHs(sv = sv_mortalcopy(&sv_no));
3811         sv_setpv(sv, pent->p_name);
3812         PUSHs(sv = sv_mortalcopy(&sv_no));
3813         for (elem = pent->p_aliases; elem && *elem; elem++) {
3814             sv_catpv(sv, *elem);
3815             if (elem[1])
3816                 sv_catpvn(sv, " ", 1);
3817         }
3818         PUSHs(sv = sv_mortalcopy(&sv_no));
3819         sv_setiv(sv, (IV)pent->p_proto);
3820     }
3821
3822     RETURN;
3823 #else
3824     DIE(no_sock_func, "getprotoent");
3825 #endif
3826 }
3827
3828 PP(pp_gsbyname)
3829 {
3830 #ifdef HAS_SOCKET
3831     return pp_gservent(ARGS);
3832 #else
3833     DIE(no_sock_func, "getservbyname");
3834 #endif
3835 }
3836
3837 PP(pp_gsbyport)
3838 {
3839 #ifdef HAS_SOCKET
3840     return pp_gservent(ARGS);
3841 #else
3842     DIE(no_sock_func, "getservbyport");
3843 #endif
3844 }
3845
3846 PP(pp_gservent)
3847 {
3848     dSP;
3849 #ifdef HAS_SOCKET
3850     I32 which = op->op_type;
3851     register char **elem;
3852     register SV *sv;
3853 #ifndef DONT_DECLARE_STD
3854     struct servent *getservbyname(const char *, const char *);
3855     struct servent *getservbynumber();
3856     struct servent *getservent(void);
3857 #endif
3858     struct servent *sent;
3859
3860     if (which == OP_GSBYNAME) {
3861         char *proto = POPp;
3862         char *name = POPp;
3863
3864         if (proto && !*proto)
3865             proto = Nullch;
3866
3867         sent = getservbyname(name, proto);
3868     }
3869     else if (which == OP_GSBYPORT) {
3870         char *proto = POPp;
3871         unsigned short port = POPu;
3872
3873 #ifdef HAS_HTONS
3874         port = htons(port);
3875 #endif
3876         sent = getservbyport(port, proto);
3877     }
3878     else
3879         sent = getservent();
3880
3881     EXTEND(SP, 4);
3882     if (GIMME != G_ARRAY) {
3883         PUSHs(sv = sv_newmortal());
3884         if (sent) {
3885             if (which == OP_GSBYNAME) {
3886 #ifdef HAS_NTOHS
3887                 sv_setiv(sv, (IV)ntohs(sent->s_port));
3888 #else
3889                 sv_setiv(sv, (IV)(sent->s_port));
3890 #endif
3891             }
3892             else
3893                 sv_setpv(sv, sent->s_name);
3894         }
3895         RETURN;
3896     }
3897
3898     if (sent) {
3899         PUSHs(sv = sv_mortalcopy(&sv_no));
3900         sv_setpv(sv, sent->s_name);
3901         PUSHs(sv = sv_mortalcopy(&sv_no));
3902         for (elem = sent->s_aliases; elem && *elem; elem++) {
3903             sv_catpv(sv, *elem);
3904             if (elem[1])
3905                 sv_catpvn(sv, " ", 1);
3906         }
3907         PUSHs(sv = sv_mortalcopy(&sv_no));
3908 #ifdef HAS_NTOHS
3909         sv_setiv(sv, (IV)ntohs(sent->s_port));
3910 #else
3911         sv_setiv(sv, (IV)(sent->s_port));
3912 #endif
3913         PUSHs(sv = sv_mortalcopy(&sv_no));
3914         sv_setpv(sv, sent->s_proto);
3915     }
3916
3917     RETURN;
3918 #else
3919     DIE(no_sock_func, "getservent");
3920 #endif
3921 }
3922
3923 PP(pp_shostent)
3924 {
3925     dSP;
3926 #ifdef HAS_SOCKET
3927     sethostent(TOPi);
3928     RETSETYES;
3929 #else
3930     DIE(no_sock_func, "sethostent");
3931 #endif
3932 }
3933
3934 PP(pp_snetent)
3935 {
3936     dSP;
3937 #ifdef HAS_SOCKET
3938     setnetent(TOPi);
3939     RETSETYES;
3940 #else
3941     DIE(no_sock_func, "setnetent");
3942 #endif
3943 }
3944
3945 PP(pp_sprotoent)
3946 {
3947     dSP;
3948 #ifdef HAS_SOCKET
3949     setprotoent(TOPi);
3950     RETSETYES;
3951 #else
3952     DIE(no_sock_func, "setprotoent");
3953 #endif
3954 }
3955
3956 PP(pp_sservent)
3957 {
3958     dSP;
3959 #ifdef HAS_SOCKET
3960     setservent(TOPi);
3961     RETSETYES;
3962 #else
3963     DIE(no_sock_func, "setservent");
3964 #endif
3965 }
3966
3967 PP(pp_ehostent)
3968 {
3969     dSP;
3970 #ifdef HAS_SOCKET
3971     endhostent();
3972     EXTEND(sp,1);
3973     RETPUSHYES;
3974 #else
3975     DIE(no_sock_func, "endhostent");
3976 #endif
3977 }
3978
3979 PP(pp_enetent)
3980 {
3981     dSP;
3982 #ifdef HAS_SOCKET
3983     endnetent();
3984     EXTEND(sp,1);
3985     RETPUSHYES;
3986 #else
3987     DIE(no_sock_func, "endnetent");
3988 #endif
3989 }
3990
3991 PP(pp_eprotoent)
3992 {
3993     dSP;
3994 #ifdef HAS_SOCKET
3995     endprotoent();
3996     EXTEND(sp,1);
3997     RETPUSHYES;
3998 #else
3999     DIE(no_sock_func, "endprotoent");
4000 #endif
4001 }
4002
4003 PP(pp_eservent)
4004 {
4005     dSP;
4006 #ifdef HAS_SOCKET
4007     endservent();
4008     EXTEND(sp,1);
4009     RETPUSHYES;
4010 #else
4011     DIE(no_sock_func, "endservent");
4012 #endif
4013 }
4014
4015 PP(pp_gpwnam)
4016 {
4017 #ifdef HAS_PASSWD
4018     return pp_gpwent(ARGS);
4019 #else
4020     DIE(no_func, "getpwnam");
4021 #endif
4022 }
4023
4024 PP(pp_gpwuid)
4025 {
4026 #ifdef HAS_PASSWD
4027     return pp_gpwent(ARGS);
4028 #else
4029     DIE(no_func, "getpwuid");
4030 #endif
4031 }
4032
4033 PP(pp_gpwent)
4034 {
4035     dSP;
4036 #ifdef HAS_PASSWD
4037     I32 which = op->op_type;
4038     register SV *sv;
4039     struct passwd *pwent;
4040
4041     if (which == OP_GPWNAM)
4042         pwent = getpwnam(POPp);
4043     else if (which == OP_GPWUID)
4044         pwent = getpwuid(POPi);
4045     else
4046         pwent = (struct passwd *)getpwent();
4047
4048     EXTEND(SP, 10);
4049     if (GIMME != G_ARRAY) {
4050         PUSHs(sv = sv_newmortal());
4051         if (pwent) {
4052             if (which == OP_GPWNAM)
4053                 sv_setiv(sv, (IV)pwent->pw_uid);
4054             else
4055                 sv_setpv(sv, pwent->pw_name);
4056         }
4057         RETURN;
4058     }
4059
4060     if (pwent) {
4061         PUSHs(sv = sv_mortalcopy(&sv_no));
4062         sv_setpv(sv, pwent->pw_name);
4063         PUSHs(sv = sv_mortalcopy(&sv_no));
4064         sv_setpv(sv, pwent->pw_passwd);
4065         PUSHs(sv = sv_mortalcopy(&sv_no));
4066         sv_setiv(sv, (IV)pwent->pw_uid);
4067         PUSHs(sv = sv_mortalcopy(&sv_no));
4068         sv_setiv(sv, (IV)pwent->pw_gid);
4069         PUSHs(sv = sv_mortalcopy(&sv_no));
4070 #ifdef PWCHANGE
4071         sv_setiv(sv, (IV)pwent->pw_change);
4072 #else
4073 #ifdef PWQUOTA
4074         sv_setiv(sv, (IV)pwent->pw_quota);
4075 #else
4076 #ifdef PWAGE
4077         sv_setpv(sv, pwent->pw_age);
4078 #endif
4079 #endif
4080 #endif
4081         PUSHs(sv = sv_mortalcopy(&sv_no));
4082 #ifdef PWCLASS
4083         sv_setpv(sv, pwent->pw_class);
4084 #else
4085 #ifdef PWCOMMENT
4086         sv_setpv(sv, pwent->pw_comment);
4087 #endif
4088 #endif
4089         PUSHs(sv = sv_mortalcopy(&sv_no));
4090         sv_setpv(sv, pwent->pw_gecos);
4091 #ifndef INCOMPLETE_TAINTS
4092         SvTAINTED_on(sv);
4093 #endif
4094         PUSHs(sv = sv_mortalcopy(&sv_no));
4095         sv_setpv(sv, pwent->pw_dir);
4096         PUSHs(sv = sv_mortalcopy(&sv_no));
4097         sv_setpv(sv, pwent->pw_shell);
4098 #ifdef PWEXPIRE
4099         PUSHs(sv = sv_mortalcopy(&sv_no));
4100         sv_setiv(sv, (IV)pwent->pw_expire);
4101 #endif
4102     }
4103     RETURN;
4104 #else
4105     DIE(no_func, "getpwent");
4106 #endif
4107 }
4108
4109 PP(pp_spwent)
4110 {
4111     dSP;
4112 #if defined(HAS_PASSWD) && !defined(CYGWIN32)
4113     setpwent();
4114     RETPUSHYES;
4115 #else
4116     DIE(no_func, "setpwent");
4117 #endif
4118 }
4119
4120 PP(pp_epwent)
4121 {
4122     dSP;
4123 #ifdef HAS_PASSWD
4124     endpwent();
4125     RETPUSHYES;
4126 #else
4127     DIE(no_func, "endpwent");
4128 #endif
4129 }
4130
4131 PP(pp_ggrnam)
4132 {
4133 #ifdef HAS_GROUP
4134     return pp_ggrent(ARGS);
4135 #else
4136     DIE(no_func, "getgrnam");
4137 #endif
4138 }
4139
4140 PP(pp_ggrgid)
4141 {
4142 #ifdef HAS_GROUP
4143     return pp_ggrent(ARGS);
4144 #else
4145     DIE(no_func, "getgrgid");
4146 #endif
4147 }
4148
4149 PP(pp_ggrent)
4150 {
4151     dSP;
4152 #ifdef HAS_GROUP
4153     I32 which = op->op_type;
4154     register char **elem;
4155     register SV *sv;
4156     struct group *grent;
4157
4158     if (which == OP_GGRNAM)
4159         grent = (struct group *)getgrnam(POPp);
4160     else if (which == OP_GGRGID)
4161         grent = (struct group *)getgrgid(POPi);
4162     else
4163         grent = (struct group *)getgrent();
4164
4165     EXTEND(SP, 4);
4166     if (GIMME != G_ARRAY) {
4167         PUSHs(sv = sv_newmortal());
4168         if (grent) {
4169             if (which == OP_GGRNAM)
4170                 sv_setiv(sv, (IV)grent->gr_gid);
4171             else
4172                 sv_setpv(sv, grent->gr_name);
4173         }
4174         RETURN;
4175     }
4176
4177     if (grent) {
4178         PUSHs(sv = sv_mortalcopy(&sv_no));
4179         sv_setpv(sv, grent->gr_name);
4180         PUSHs(sv = sv_mortalcopy(&sv_no));
4181         sv_setpv(sv, grent->gr_passwd);
4182         PUSHs(sv = sv_mortalcopy(&sv_no));
4183         sv_setiv(sv, (IV)grent->gr_gid);
4184         PUSHs(sv = sv_mortalcopy(&sv_no));
4185         for (elem = grent->gr_mem; elem && *elem; elem++) {
4186             sv_catpv(sv, *elem);
4187             if (elem[1])
4188                 sv_catpvn(sv, " ", 1);
4189         }
4190     }
4191
4192     RETURN;
4193 #else
4194     DIE(no_func, "getgrent");
4195 #endif
4196 }
4197
4198 PP(pp_sgrent)
4199 {
4200     dSP;
4201 #ifdef HAS_GROUP
4202     setgrent();
4203     RETPUSHYES;
4204 #else
4205     DIE(no_func, "setgrent");
4206 #endif
4207 }
4208
4209 PP(pp_egrent)
4210 {
4211     dSP;
4212 #ifdef HAS_GROUP
4213     endgrent();
4214     RETPUSHYES;
4215 #else
4216     DIE(no_func, "endgrent");
4217 #endif
4218 }
4219
4220 PP(pp_getlogin)
4221 {
4222     dSP; dTARGET;
4223 #ifdef HAS_GETLOGIN
4224     char *tmps;
4225     EXTEND(SP, 1);
4226     if (!(tmps = getlogin()))
4227         RETPUSHUNDEF;
4228     PUSHp(tmps, strlen(tmps));
4229     RETURN;
4230 #else
4231     DIE(no_func, "getlogin");
4232 #endif
4233 }
4234
4235 /* Miscellaneous. */
4236
4237 PP(pp_syscall)
4238 {
4239 #ifdef HAS_SYSCALL   
4240     dSP; dMARK; dORIGMARK; dTARGET;
4241     register I32 items = SP - MARK;
4242     unsigned long a[20];
4243     register I32 i = 0;
4244     I32 retval = -1;
4245     MAGIC *mg;
4246
4247     if (tainting) {
4248         while (++MARK <= SP) {
4249             if (SvTAINTED(*MARK)) {
4250                 TAINT;
4251                 break;
4252             }
4253         }
4254         MARK = ORIGMARK;
4255         TAINT_PROPER("syscall");
4256     }
4257
4258     /* This probably won't work on machines where sizeof(long) != sizeof(int)
4259      * or where sizeof(long) != sizeof(char*).  But such machines will
4260      * not likely have syscall implemented either, so who cares?
4261      */
4262     while (++MARK <= SP) {
4263         if (SvNIOK(*MARK) || !i)
4264             a[i++] = SvIV(*MARK);
4265         else if (*MARK == &sv_undef)
4266             a[i++] = 0;
4267         else 
4268             a[i++] = (unsigned long)SvPV_force(*MARK, na);
4269         if (i > 15)
4270             break;
4271     }
4272     switch (items) {
4273     default:
4274         DIE("Too many args to syscall");
4275     case 0:
4276         DIE("Too few args to syscall");
4277     case 1:
4278         retval = syscall(a[0]);
4279         break;
4280     case 2:
4281         retval = syscall(a[0],a[1]);
4282         break;
4283     case 3:
4284         retval = syscall(a[0],a[1],a[2]);
4285         break;
4286     case 4:
4287         retval = syscall(a[0],a[1],a[2],a[3]);
4288         break;
4289     case 5:
4290         retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4291         break;
4292     case 6:
4293         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4294         break;
4295     case 7:
4296         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4297         break;
4298     case 8:
4299         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4300         break;
4301 #ifdef atarist
4302     case 9:
4303         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4304         break;
4305     case 10:
4306         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4307         break;
4308     case 11:
4309         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4310           a[10]);
4311         break;
4312     case 12:
4313         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4314           a[10],a[11]);
4315         break;
4316     case 13:
4317         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4318           a[10],a[11],a[12]);
4319         break;
4320     case 14:
4321         retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4322           a[10],a[11],a[12],a[13]);
4323         break;
4324 #endif /* atarist */
4325     }
4326     SP = ORIGMARK;
4327     PUSHi(retval);
4328     RETURN;
4329 #else
4330     DIE(no_func, "syscall");
4331 #endif
4332 }
4333
4334 #ifdef FCNTL_EMULATE_FLOCK
4335  
4336 /*  XXX Emulate flock() with fcntl().
4337     What's really needed is a good file locking module.
4338 */
4339
4340 static int
4341 fcntl_emulate_flock(int fd, int operation)
4342 {
4343     struct flock flock;
4344  
4345     switch (operation & ~LOCK_NB) {
4346     case LOCK_SH:
4347         flock.l_type = F_RDLCK;
4348         break;
4349     case LOCK_EX:
4350         flock.l_type = F_WRLCK;
4351         break;
4352     case LOCK_UN:
4353         flock.l_type = F_UNLCK;
4354         break;
4355     default:
4356         errno = EINVAL;
4357         return -1;
4358     }
4359     flock.l_whence = SEEK_SET;
4360     flock.l_start = flock.l_len = 0L;
4361  
4362     return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4363 }
4364
4365 #endif /* FCNTL_EMULATE_FLOCK */
4366
4367 #ifdef LOCKF_EMULATE_FLOCK
4368
4369 /*  XXX Emulate flock() with lockf().  This is just to increase
4370     portability of scripts.  The calls are not completely
4371     interchangeable.  What's really needed is a good file
4372     locking module.
4373 */
4374
4375 /*  The lockf() constants might have been defined in <unistd.h>.
4376     Unfortunately, <unistd.h> causes troubles on some mixed
4377     (BSD/POSIX) systems, such as SunOS 4.1.3.
4378
4379    Further, the lockf() constants aren't POSIX, so they might not be
4380    visible if we're compiling with _POSIX_SOURCE defined.  Thus, we'll
4381    just stick in the SVID values and be done with it.  Sigh.
4382 */
4383
4384 # ifndef F_ULOCK
4385 #  define F_ULOCK       0       /* Unlock a previously locked region */
4386 # endif
4387 # ifndef F_LOCK
4388 #  define F_LOCK        1       /* Lock a region for exclusive use */
4389 # endif
4390 # ifndef F_TLOCK
4391 #  define F_TLOCK       2       /* Test and lock a region for exclusive use */
4392 # endif
4393 # ifndef F_TEST
4394 #  define F_TEST        3       /* Test a region for other processes locks */
4395 # endif
4396
4397 static int
4398 lockf_emulate_flock (fd, operation)
4399 int fd;
4400 int operation;
4401 {
4402     int i;
4403     int save_errno;
4404     Off_t pos;
4405
4406     /* flock locks entire file so for lockf we need to do the same      */
4407     save_errno = errno;
4408     pos = lseek(fd, (Off_t)0, SEEK_CUR);    /* get pos to restore later */
4409     if (pos > 0)        /* is seekable and needs to be repositioned     */
4410         if (lseek(fd, (Off_t)0, SEEK_SET) < 0)
4411             pos = -1;   /* seek failed, so don't seek back afterwards   */
4412     errno = save_errno;
4413
4414     switch (operation) {
4415
4416         /* LOCK_SH - get a shared lock */
4417         case LOCK_SH:
4418         /* LOCK_EX - get an exclusive lock */
4419         case LOCK_EX:
4420             i = lockf (fd, F_LOCK, 0);
4421             break;
4422
4423         /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4424         case LOCK_SH|LOCK_NB:
4425         /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4426         case LOCK_EX|LOCK_NB:
4427             i = lockf (fd, F_TLOCK, 0);
4428             if (i == -1)
4429                 if ((errno == EAGAIN) || (errno == EACCES))
4430                     errno = EWOULDBLOCK;
4431             break;
4432
4433         /* LOCK_UN - unlock (non-blocking is a no-op) */
4434         case LOCK_UN:
4435         case LOCK_UN|LOCK_NB:
4436             i = lockf (fd, F_ULOCK, 0);
4437             break;
4438
4439         /* Default - can't decipher operation */
4440         default:
4441             i = -1;
4442             errno = EINVAL;
4443             break;
4444     }
4445
4446     if (pos > 0)      /* need to restore position of the handle */
4447         lseek(fd, pos, SEEK_SET);       /* ignore error here    */
4448
4449     return (i);
4450 }
4451
4452 #endif /* LOCKF_EMULATE_FLOCK */