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