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