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