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