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