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