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