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