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