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