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