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