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