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