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