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