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