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