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