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