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