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