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