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