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