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