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