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