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