This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Tweaks to open(my $fh,...) stuff
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW
1/* pp_sys.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, 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
8ac85365
NIS
25#ifdef HAS_SYSCALL
26#ifdef __cplusplus
27extern "C" int syscall(unsigned long,...);
28#endif
29#endif
30
76c32331
PP
31#ifdef I_SYS_WAIT
32# include <sys/wait.h>
33#endif
34
35#ifdef I_SYS_RESOURCE
36# include <sys/resource.h>
16d20bd9 37#endif
a0d0e21e
LW
38
39#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
40# include <sys/socket.h>
3fd537d4
JH
41# ifdef I_NETDB
42# include <netdb.h>
43# endif
a0d0e21e
LW
44# ifndef ENOTSOCK
45# ifdef I_NET_ERRNO
46# include <net/errno.h>
47# endif
48# endif
49#endif
50
51#ifdef HAS_SELECT
52#ifdef I_SYS_SELECT
a0d0e21e
LW
53#include <sys/select.h>
54#endif
55#endif
a0d0e21e 56
dc45a647
MB
57/* XXX Configure test needed.
58 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS
59 applications, see "extern int errno in perl.h". Creating such
60 a test requires taking into account the differences between
61 compiling multithreaded and singlethreaded ($ccflags et al).
62 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647
MB
63*/
64#if defined(HOST_NOT_FOUND) && !defined(h_errno)
a0d0e21e
LW
65extern int h_errno;
66#endif
67
68#ifdef HAS_PASSWD
69# ifdef I_PWD
70# include <pwd.h>
71# else
72 struct passwd *getpwnam _((char *));
73 struct passwd *getpwuid _((Uid_t));
74# endif
28e8609d 75# ifdef HAS_GETPWENT
a0d0e21e 76 struct passwd *getpwent _((void));
28e8609d 77# endif
a0d0e21e
LW
78#endif
79
80#ifdef HAS_GROUP
81# ifdef I_GRP
82# include <grp.h>
83# else
84 struct group *getgrnam _((char *));
85 struct group *getgrgid _((Gid_t));
86# endif
28e8609d 87# ifdef HAS_GETGRENT
a0d0e21e 88 struct group *getgrent _((void));
28e8609d 89# endif
a0d0e21e
LW
90#endif
91
92#ifdef I_UTIME
3730b96e 93# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1
PP
94# include <sys/utime.h>
95# else
96# include <utime.h>
97# endif
a0d0e21e
LW
98#endif
99#ifdef I_FCNTL
100#include <fcntl.h>
101#endif
102#ifdef I_SYS_FILE
103#include <sys/file.h>
104#endif
105
54310121
PP
106/* Put this after #includes because fork and vfork prototypes may conflict. */
107#ifndef HAS_VFORK
108# define vfork fork
109#endif
110
d574b85e
CS
111/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
112#ifndef Sock_size_t
137443ea 113# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS
114# define Sock_size_t Size_t
115# else
116# define Sock_size_t int
117# endif
54310121
PP
118#endif
119
a0d0e21e
LW
120#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
121static int dooneliner _((char *cmd, char *filename));
122#endif
cbdc8872
PP
123
124#ifdef HAS_CHSIZE
cd52b7b2
PP
125# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
126# undef my_chsize
127# endif
6ad3d225 128# define my_chsize PerlLIO_chsize
cbdc8872
PP
129#endif
130
ff68c719
PP
131#ifdef HAS_FLOCK
132# define FLOCK flock
133#else /* no flock() */
134
36477c24
PP
135 /* fcntl.h might not have been included, even if it exists, because
136 the current Configure only sets I_FCNTL if it's needed to pick up
137 the *_OK constants. Make sure it has been included before testing
138 the fcntl() locking constants. */
139# if defined(HAS_FCNTL) && !defined(I_FCNTL)
140# include <fcntl.h>
141# endif
142
ff68c719
PP
143# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
144# define FLOCK fcntl_emulate_flock
145# define FCNTL_EMULATE_FLOCK
146# else /* no flock() or fcntl(F_SETLK,...) */
147# ifdef HAS_LOCKF
148# define FLOCK lockf_emulate_flock
149# define LOCKF_EMULATE_FLOCK
150# endif /* lockf */
151# endif /* no flock() or fcntl(F_SETLK,...) */
152
153# ifdef FLOCK
13826f2c 154 static int FLOCK _((int, int));
ff68c719
PP
155
156 /*
157 * These are the flock() constants. Since this sytems doesn't have
158 * flock(), the values of the constants are probably not available.
159 */
160# ifndef LOCK_SH
161# define LOCK_SH 1
162# endif
163# ifndef LOCK_EX
164# define LOCK_EX 2
165# endif
166# ifndef LOCK_NB
167# define LOCK_NB 4
168# endif
169# ifndef LOCK_UN
170# define LOCK_UN 8
171# endif
172# endif /* emulating flock() */
173
174#endif /* no flock() */
55497cff 175
85ab1d1d
JH
176#define ZBTLEN 10
177static char zero_but_true[ZBTLEN + 1] = "0 but true";
178
5ff3f7a4
GS
179#if defined(I_SYS_ACCESS) && !defined(R_OK)
180# include <sys/access.h>
181#endif
182
183#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
184#undef PERL_EFF_ACCESS_W_OK
185#undef PERL_EFF_ACCESS_X_OK
186
187/* F_OK unused: if stat() cannot find it... */
188
189#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 190 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS
191# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
192# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
193# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
194#endif
195
196#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS
197# if defined(I_SYS_SECURITY)
198# include <sys/security.h>
199# endif
c955f117
JH
200 /* XXX Configure test needed for eaccess */
201# ifdef ACC_SELF
202 /* HP SecureWare */
203# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
204# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
205# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
206# else
207 /* SCO */
208# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
209# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
210# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
211# endif
5ff3f7a4
GS
212#endif
213
214#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 215 /* AIX */
5ff3f7a4
GS
216# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
217# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
218# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
219#endif
220
327c3667
GS
221#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
222 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
223 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 224/* The Hard Way. */
327c3667
GS
225STATIC int
226emulate_eaccess (const char* path, int mode) {
5ff3f7a4
GS
227 Uid_t ruid = getuid();
228 Uid_t euid = geteuid();
229 Gid_t rgid = getgid();
230 Gid_t egid = getegid();
231 int res;
232
233 MUTEX_LOCK(&PL_cred_mutex);
234#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
85ab1d1d 235 croak("switching effective uid is not implemented");
5ff3f7a4
GS
236#else
237#ifdef HAS_SETREUID
238 if (setreuid(euid, ruid))
239#else
240#ifdef HAS_SETRESUID
241 if (setresuid(euid, ruid, (Uid_t)-1))
242#endif
243#endif
85ab1d1d 244 croak("entering effective uid failed");
5ff3f7a4
GS
245#endif
246
247#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
85ab1d1d 248 croak("switching effective gid is not implemented");
5ff3f7a4
GS
249#else
250#ifdef HAS_SETREGID
251 if (setregid(egid, rgid))
252#else
253#ifdef HAS_SETRESGID
254 if (setresgid(egid, rgid, (Gid_t)-1))
255#endif
256#endif
85ab1d1d 257 croak("entering effective gid failed");
5ff3f7a4
GS
258#endif
259
260 res = access(path, mode);
261
262#ifdef HAS_SETREUID
263 if (setreuid(ruid, euid))
264#else
265#ifdef HAS_SETRESUID
266 if (setresuid(ruid, euid, (Uid_t)-1))
267#endif
268#endif
85ab1d1d 269 croak("leaving effective uid failed");
5ff3f7a4
GS
270
271#ifdef HAS_SETREGID
272 if (setregid(rgid, egid))
273#else
274#ifdef HAS_SETRESGID
275 if (setresgid(rgid, egid, (Gid_t)-1))
276#endif
277#endif
85ab1d1d 278 croak("leaving effective gid failed");
5ff3f7a4
GS
279 MUTEX_UNLOCK(&PL_cred_mutex);
280
281 return res;
282}
283# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
284# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
285# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
286#endif
287
288#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667
GS
289STATIC int
290emulate_eaccess (const char* path, int mode) {
85ab1d1d 291 croak("switching effective uid is not implemented");
5ff3f7a4
GS
292 /*NOTREACHED*/
293 return -1;
294}
295#endif
296
a0d0e21e
LW
297PP(pp_backtick)
298{
4e35701f 299 djSP; dTARGET;
760ac839 300 PerlIO *fp;
2d8e6c8d
GS
301 STRLEN n_a;
302 char *tmps = POPpx;
54310121
PP
303 I32 gimme = GIMME_V;
304
a0d0e21e 305 TAINT_PROPER("``");
6ad3d225 306 fp = PerlProc_popen(tmps, "r");
a0d0e21e 307 if (fp) {
54310121 308 if (gimme == G_VOID) {
96827780
MB
309 char tmpbuf[256];
310 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121
PP
311 /*SUPPRESS 530*/
312 ;
313 }
314 else if (gimme == G_SCALAR) {
aa689395 315 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW
316 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
317 /*SUPPRESS 530*/
318 ;
319 XPUSHs(TARG);
aa689395 320 SvTAINTED_on(TARG);
a0d0e21e
LW
321 }
322 else {
323 SV *sv;
324
325 for (;;) {
8d6dde3e 326 sv = NEWSV(56, 79);
a0d0e21e
LW
327 if (sv_gets(sv, fp, 0) == Nullch) {
328 SvREFCNT_dec(sv);
329 break;
330 }
331 XPUSHs(sv_2mortal(sv));
332 if (SvLEN(sv) - SvCUR(sv) > 20) {
333 SvLEN_set(sv, SvCUR(sv)+1);
334 Renew(SvPVX(sv), SvLEN(sv), char);
335 }
aa689395 336 SvTAINTED_on(sv);
a0d0e21e
LW
337 }
338 }
6ad3d225 339 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 340 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW
341 }
342 else {
f86702cc 343 STATUS_NATIVE_SET(-1);
54310121 344 if (gimme == G_SCALAR)
a0d0e21e
LW
345 RETPUSHUNDEF;
346 }
347
348 RETURN;
349}
350
351PP(pp_glob)
352{
353 OP *result;
f5284f61
IZ
354 tryAMAGICunTARGET(iter, -1);
355
a0d0e21e 356 ENTER;
a0d0e21e 357
c90c0ff4 358#ifndef VMS
3280af22 359 if (PL_tainting) {
7bac28a0
PP
360 /*
361 * The external globbing program may use things we can't control,
362 * so for security reasons we must assume the worst.
363 */
364 TAINT;
22c35a8c 365 taint_proper(PL_no_security, "glob");
7bac28a0 366 }
c90c0ff4 367#endif /* !VMS */
7bac28a0 368
3280af22
NIS
369 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
370 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 371
3280af22 372 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 373 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd
PP
374#ifndef DOSISH
375#ifndef CSH
6b88bc9c 376 *SvPVX(PL_rs) = '\n';
a0d0e21e 377#endif /* !CSH */
55497cff 378#endif /* !DOSISH */
c07a80fd 379
a0d0e21e
LW
380 result = do_readline();
381 LEAVE;
382 return result;
383}
384
15e52e56 385#if 0 /* XXX never used! */
a0d0e21e
LW
386PP(pp_indread)
387{
2d8e6c8d
GS
388 STRLEN n_a;
389 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW
390 return do_readline();
391}
15e52e56 392#endif
a0d0e21e
LW
393
394PP(pp_rcatline)
395{
3280af22 396 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW
397 return do_readline();
398}
399
400PP(pp_warn)
401{
4e35701f 402 djSP; dMARK;
06bf62c7 403 SV *tmpsv;
a0d0e21e 404 char *tmps;
06bf62c7 405 STRLEN len;
a0d0e21e
LW
406 if (SP - MARK != 1) {
407 dTARGET;
3280af22 408 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 409 tmpsv = TARG;
a0d0e21e
LW
410 SP = MARK + 1;
411 }
412 else {
06bf62c7 413 tmpsv = TOPs;
a0d0e21e 414 }
06bf62c7
GS
415 tmps = SvPV(tmpsv, len);
416 if (!tmps || !len) {
4e6ea2c3
GS
417 SV *error = ERRSV;
418 (void)SvUPGRADE(error, SVt_PV);
419 if (SvPOK(error) && SvCUR(error))
420 sv_catpv(error, "\t...caught");
06bf62c7
GS
421 tmpsv = error;
422 tmps = SvPV(tmpsv, len);
a0d0e21e 423 }
06bf62c7
GS
424 if (!tmps || !len)
425 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
426
427 warn("%_", tmpsv);
a0d0e21e
LW
428 RETSETYES;
429}
430
431PP(pp_die)
432{
4e35701f 433 djSP; dMARK;
a0d0e21e 434 char *tmps;
06bf62c7
GS
435 SV *tmpsv;
436 STRLEN len;
437 bool multiarg = 0;
a0d0e21e
LW
438 if (SP - MARK != 1) {
439 dTARGET;
3280af22 440 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS
441 tmpsv = TARG;
442 tmps = SvPV(tmpsv, len);
443 multiarg = 1;
a0d0e21e
LW
444 SP = MARK + 1;
445 }
446 else {
4e6ea2c3 447 tmpsv = TOPs;
06bf62c7 448 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 449 }
06bf62c7 450 if (!tmps || !len) {
4e6ea2c3
GS
451 SV *error = ERRSV;
452 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS
453 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
454 if (!multiarg)
4e6ea2c3 455 SvSetSV(error,tmpsv);
06bf62c7 456 else if (sv_isobject(error)) {
05423cc9
GS
457 HV *stash = SvSTASH(SvRV(error));
458 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
459 if (gv) {
3280af22
NIS
460 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
461 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS
462 EXTEND(SP, 3);
463 PUSHMARK(SP);
464 PUSHs(error);
465 PUSHs(file);
466 PUSHs(line);
467 PUTBACK;
468 perl_call_sv((SV*)GvCV(gv),
469 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 470 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS
471 }
472 }
06bf62c7 473 DIE(Nullch);
4e6ea2c3
GS
474 }
475 else {
476 if (SvPOK(error) && SvCUR(error))
477 sv_catpv(error, "\t...propagated");
06bf62c7
GS
478 tmpsv = error;
479 tmps = SvPV(tmpsv, len);
4e6ea2c3 480 }
a0d0e21e 481 }
06bf62c7
GS
482 if (!tmps || !len)
483 tmpsv = sv_2mortal(newSVpvn("Died", 4));
484
485 DIE("%_", tmpsv);
a0d0e21e
LW
486}
487
488/* I/O. */
489
490PP(pp_open)
491{
4e35701f 492 djSP; dTARGET;
a0d0e21e
LW
493 GV *gv;
494 SV *sv;
495 char *tmps;
496 STRLEN len;
497
498 if (MAXARG > 1)
499 sv = POPs;
5f05dabc 500 if (!isGV(TOPs))
22c35a8c 501 DIE(PL_no_usym, "filehandle");
5f05dabc
PP
502 if (MAXARG <= 1)
503 sv = GvSV(TOPs);
a0d0e21e 504 gv = (GV*)POPs;
5f05dabc 505 if (!isGV(gv))
22c35a8c 506 DIE(PL_no_usym, "filehandle");
36477c24
PP
507 if (GvIOp(gv))
508 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea
NIS
509
510#if 0 /* no undef means tmpfile() yet */
3eb568f1
NIS
511 if (sv == &PL_sv_undef) {
512#ifdef PerlIO
513 PerlIO *fp = PerlIO_tmpfile();
514#else
515 PerlIO *fp = tmpfile();
516#endif
517 if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
518 PUSHi( (I32)PL_forkprocess );
519 else
520 RETPUSHUNDEF;
521 RETURN;
522 }
853846ea
NIS
523#endif /* no undef means tmpfile() yet */
524
a0d0e21e 525 tmps = SvPV(sv, len);
9d116dd7 526 if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
3280af22
NIS
527 PUSHi( (I32)PL_forkprocess );
528 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW
529 PUSHi(0);
530 else
531 RETPUSHUNDEF;
532 RETURN;
533}
534
535PP(pp_close)
536{
4e35701f 537 djSP;
a0d0e21e 538 GV *gv;
1d603a67 539 MAGIC *mg;
a0d0e21e
LW
540
541 if (MAXARG == 0)
3280af22 542 gv = PL_defoutgv;
a0d0e21e
LW
543 else
544 gv = (GV*)POPs;
1d603a67 545
33c27489 546 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 547 PUSHMARK(SP);
33c27489 548 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB
549 PUTBACK;
550 ENTER;
551 perl_call_method("CLOSE", G_SCALAR);
552 LEAVE;
553 SPAGAIN;
554 RETURN;
555 }
a0d0e21e 556 EXTEND(SP, 1);
54310121 557 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW
558 RETURN;
559}
560
561PP(pp_pipe_op)
562{
4e35701f 563 djSP;
a0d0e21e
LW
564#ifdef HAS_PIPE
565 GV *rgv;
566 GV *wgv;
567 register IO *rstio;
568 register IO *wstio;
569 int fd[2];
570
571 wgv = (GV*)POPs;
572 rgv = (GV*)POPs;
573
574 if (!rgv || !wgv)
575 goto badexit;
576
4633a7c4 577 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
22c35a8c 578 DIE(PL_no_usym, "filehandle");
a0d0e21e
LW
579 rstio = GvIOn(rgv);
580 wstio = GvIOn(wgv);
581
582 if (IoIFP(rstio))
583 do_close(rgv, FALSE);
584 if (IoIFP(wstio))
585 do_close(wgv, FALSE);
586
6ad3d225 587 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW
588 goto badexit;
589
760ac839
LW
590 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
591 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
592 IoIFP(wstio) = IoOFP(wstio);
593 IoTYPE(rstio) = '<';
594 IoTYPE(wstio) = '>';
595
596 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 597 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 598 else PerlLIO_close(fd[0]);
760ac839 599 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 600 else PerlLIO_close(fd[1]);
a0d0e21e
LW
601 goto badexit;
602 }
4771b018
GS
603#if defined(HAS_FCNTL) && defined(F_SETFD)
604 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
605 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
606#endif
a0d0e21e
LW
607 RETPUSHYES;
608
609badexit:
610 RETPUSHUNDEF;
611#else
22c35a8c 612 DIE(PL_no_func, "pipe");
a0d0e21e
LW
613#endif
614}
615
616PP(pp_fileno)
617{
4e35701f 618 djSP; dTARGET;
a0d0e21e
LW
619 GV *gv;
620 IO *io;
760ac839 621 PerlIO *fp;
a0d0e21e
LW
622 if (MAXARG < 1)
623 RETPUSHUNDEF;
624 gv = (GV*)POPs;
625 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
626 RETPUSHUNDEF;
760ac839 627 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW
628 RETURN;
629}
630
631PP(pp_umask)
632{
4e35701f 633 djSP; dTARGET;
761237fe 634 Mode_t anum;
a0d0e21e
LW
635
636#ifdef HAS_UMASK
637 if (MAXARG < 1) {
6ad3d225
GS
638 anum = PerlLIO_umask(0);
639 (void)PerlLIO_umask(anum);
a0d0e21e
LW
640 }
641 else
6ad3d225 642 anum = PerlLIO_umask(POPi);
a0d0e21e
LW
643 TAINT_PROPER("umask");
644 XPUSHi(anum);
645#else
eec2d3df
GS
646 /* Only DIE if trying to restrict permissions on `user' (self).
647 * Otherwise it's harmless and more useful to just return undef
648 * since 'group' and 'other' concepts probably don't exist here. */
649 if (MAXARG >= 1 && (POPi & 0700))
650 DIE("umask not implemented");
6b88bc9c 651 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
652#endif
653 RETURN;
654}
655
656PP(pp_binmode)
657{
4e35701f 658 djSP;
a0d0e21e
LW
659 GV *gv;
660 IO *io;
760ac839 661 PerlIO *fp;
a0d0e21e
LW
662
663 if (MAXARG < 1)
664 RETPUSHUNDEF;
665
666 gv = (GV*)POPs;
667
668 EXTEND(SP, 1);
669 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 670 RETPUSHUNDEF;
a0d0e21e 671
491527d0 672 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW
673 RETPUSHYES;
674 else
675 RETPUSHUNDEF;
a0d0e21e
LW
676}
677
b8e3bfaf 678
a0d0e21e
LW
679PP(pp_tie)
680{
4e35701f 681 djSP;
e336de0d 682 dMARK;
a0d0e21e
LW
683 SV *varsv;
684 HV* stash;
685 GV *gv;
a0d0e21e 686 SV *sv;
3280af22 687 I32 markoff = MARK - PL_stack_base;
a0d0e21e 688 char *methname;
6b05c17a 689 int how = 'P';
e336de0d 690 U32 items;
2d8e6c8d 691 STRLEN n_a;
a0d0e21e 692
e336de0d 693 varsv = *++MARK;
6b05c17a
NIS
694 switch(SvTYPE(varsv)) {
695 case SVt_PVHV:
696 methname = "TIEHASH";
697 break;
698 case SVt_PVAV:
699 methname = "TIEARRAY";
700 break;
701 case SVt_PVGV:
702 methname = "TIEHANDLE";
703 how = 'q';
704 break;
705 default:
706 methname = "TIESCALAR";
707 how = 'q';
708 break;
709 }
e336de0d
GS
710 items = SP - MARK++;
711 if (sv_isobject(*MARK)) {
6b05c17a 712 ENTER;
e788e7d3 713 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
714 PUSHMARK(SP);
715 EXTEND(SP,items);
716 while (items--)
717 PUSHs(*MARK++);
718 PUTBACK;
6b05c17a
NIS
719 perl_call_method(methname, G_SCALAR);
720 }
721 else {
722 /* Not clear why we don't call perl_call_method here too.
723 * perhaps to get different error message ?
724 */
e336de0d 725 stash = gv_stashsv(*MARK, FALSE);
6b05c17a
NIS
726 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
727 DIE("Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 728 methname, SvPV(*MARK,n_a));
6b05c17a
NIS
729 }
730 ENTER;
e788e7d3 731 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS
732 PUSHMARK(SP);
733 EXTEND(SP,items);
734 while (items--)
735 PUSHs(*MARK++);
736 PUTBACK;
6b05c17a
NIS
737 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
738 }
a0d0e21e
LW
739 SPAGAIN;
740
741 sv = TOPs;
d3acc0f7 742 POPSTACK;
a0d0e21e 743 if (sv_isobject(sv)) {
33c27489
GS
744 sv_unmagic(varsv, how);
745 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW
746 }
747 LEAVE;
3280af22 748 SP = PL_stack_base + markoff;
a0d0e21e
LW
749 PUSHs(sv);
750 RETURN;
751}
752
753PP(pp_untie)
754{
4e35701f 755 djSP;
33c27489
GS
756 SV *sv = POPs;
757 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 758
599cee73 759 if (ckWARN(WARN_UNTIE)) {
cbdc8872 760 MAGIC * mg ;
33c27489 761 if (mg = SvTIED_mg(sv, how)) {
cbdc8872 762 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
599cee73
PM
763 warner(WARN_UNTIE,
764 "untie attempted while %lu inner references still exist",
765 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872
PP
766 }
767 }
768
33c27489 769 sv_unmagic(sv, how);
55497cff 770 RETPUSHYES;
a0d0e21e
LW
771}
772
c07a80fd
PP
773PP(pp_tied)
774{
4e35701f 775 djSP;
33c27489
GS
776 SV *sv = POPs;
777 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
778 MAGIC *mg;
c07a80fd 779
33c27489
GS
780 if (mg = SvTIED_mg(sv, how)) {
781 SV *osv = SvTIED_obj(sv, mg);
782 if (osv == mg->mg_obj)
783 osv = sv_mortalcopy(osv);
784 PUSHs(osv);
785 RETURN;
c07a80fd 786 }
c07a80fd
PP
787 RETPUSHUNDEF;
788}
789
a0d0e21e
LW
790PP(pp_dbmopen)
791{
4e35701f 792 djSP;
a0d0e21e
LW
793 HV *hv;
794 dPOPPOPssrl;
795 HV* stash;
796 GV *gv;
a0d0e21e
LW
797 SV *sv;
798
799 hv = (HV*)POPs;
800
3280af22 801 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW
802 sv_setpv(sv, "AnyDBM_File");
803 stash = gv_stashsv(sv, FALSE);
8ebc5c01 804 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 805 PUTBACK;
4633a7c4 806 perl_require_pv("AnyDBM_File.pm");
a0d0e21e 807 SPAGAIN;
8ebc5c01 808 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
a0d0e21e
LW
809 DIE("No dbm on this machine");
810 }
811
57d3b86d 812 ENTER;
924508f0 813 PUSHMARK(SP);
6b05c17a 814
924508f0 815 EXTEND(SP, 5);
a0d0e21e
LW
816 PUSHs(sv);
817 PUSHs(left);
818 if (SvIV(right))
819 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
820 else
821 PUSHs(sv_2mortal(newSViv(O_RDWR)));
822 PUSHs(right);
57d3b86d 823 PUTBACK;
38a03e6e 824 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
825 SPAGAIN;
826
827 if (!sv_isobject(TOPs)) {
924508f0
GS
828 SP--;
829 PUSHMARK(SP);
a0d0e21e
LW
830 PUSHs(sv);
831 PUSHs(left);
832 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
833 PUSHs(right);
a0d0e21e 834 PUTBACK;
38a03e6e 835 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW
836 SPAGAIN;
837 }
838
6b05c17a
NIS
839 if (sv_isobject(TOPs)) {
840 sv_unmagic((SV *) hv, 'P');
a0d0e21e 841 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 842 }
a0d0e21e
LW
843 LEAVE;
844 RETURN;
845}
846
847PP(pp_dbmclose)
848{
849 return pp_untie(ARGS);
850}
851
852PP(pp_sselect)
853{
4e35701f 854 djSP; dTARGET;
a0d0e21e
LW
855#ifdef HAS_SELECT
856 register I32 i;
857 register I32 j;
858 register char *s;
859 register SV *sv;
860 double value;
861 I32 maxlen = 0;
862 I32 nfound;
863 struct timeval timebuf;
864 struct timeval *tbuf = &timebuf;
865 I32 growsize;
866 char *fd_sets[4];
2d8e6c8d 867 STRLEN n_a;
a0d0e21e
LW
868#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
869 I32 masksize;
870 I32 offset;
871 I32 k;
872
873# if BYTEORDER & 0xf0000
874# define ORDERBYTE (0x88888888 - BYTEORDER)
875# else
876# define ORDERBYTE (0x4444 - BYTEORDER)
877# endif
878
879#endif
880
881 SP -= 4;
882 for (i = 1; i <= 3; i++) {
883 if (!SvPOK(SP[i]))
884 continue;
885 j = SvCUR(SP[i]);
886 if (maxlen < j)
887 maxlen = j;
888 }
889
5ff3f7a4 890/* little endians can use vecs directly */
a0d0e21e 891#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 892# if SELECT_MIN_BITS > 1
f2da832e
JH
893 /* If SELECT_MIN_BITS is greater than one we most probably will want
894 * to align the sizes with SELECT_MIN_BITS/8 because for example
895 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W
896 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
897 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 898 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 899# else
4633a7c4 900 growsize = sizeof(fd_set);
5ff3f7a4
GS
901# endif
902# else
903# ifdef NFDBITS
a0d0e21e 904
5ff3f7a4
GS
905# ifndef NBBY
906# define NBBY 8
907# endif
a0d0e21e
LW
908
909 masksize = NFDBITS / NBBY;
5ff3f7a4 910# else
a0d0e21e 911 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 912# endif
a0d0e21e
LW
913 growsize = maxlen + (masksize - (maxlen % masksize));
914 Zero(&fd_sets[0], 4, char*);
915#endif
916
917 sv = SP[4];
918 if (SvOK(sv)) {
919 value = SvNV(sv);
920 if (value < 0.0)
921 value = 0.0;
922 timebuf.tv_sec = (long)value;
923 value -= (double)timebuf.tv_sec;
924 timebuf.tv_usec = (long)(value * 1000000.0);
925 }
926 else
927 tbuf = Null(struct timeval*);
928
929 for (i = 1; i <= 3; i++) {
930 sv = SP[i];
931 if (!SvOK(sv)) {
932 fd_sets[i] = 0;
933 continue;
934 }
935 else if (!SvPOK(sv))
2d8e6c8d 936 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW
937 j = SvLEN(sv);
938 if (j < growsize) {
939 Sv_Grow(sv, growsize);
a0d0e21e 940 }
c07a80fd
PP
941 j = SvCUR(sv);
942 s = SvPVX(sv) + j;
943 while (++j <= growsize) {
944 *s++ = '\0';
945 }
946
a0d0e21e
LW
947#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
948 s = SvPVX(sv);
949 New(403, fd_sets[i], growsize, char);
950 for (offset = 0; offset < growsize; offset += masksize) {
951 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
952 fd_sets[i][j+offset] = s[(k % masksize) + offset];
953 }
954#else
955 fd_sets[i] = SvPVX(sv);
956#endif
957 }
958
6ad3d225 959 nfound = PerlSock_select(
a0d0e21e
LW
960 maxlen * 8,
961 (Select_fd_set_t) fd_sets[1],
962 (Select_fd_set_t) fd_sets[2],
963 (Select_fd_set_t) fd_sets[3],
964 tbuf);
965 for (i = 1; i <= 3; i++) {
966 if (fd_sets[i]) {
967 sv = SP[i];
968#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
969 s = SvPVX(sv);
970 for (offset = 0; offset < growsize; offset += masksize) {
971 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
972 s[(k % masksize) + offset] = fd_sets[i][j+offset];
973 }
974 Safefree(fd_sets[i]);
975#endif
976 SvSETMAGIC(sv);
977 }
978 }
979
980 PUSHi(nfound);
981 if (GIMME == G_ARRAY && tbuf) {
982 value = (double)(timebuf.tv_sec) +
983 (double)(timebuf.tv_usec) / 1000000.0;
3280af22 984 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW
985 sv_setnv(sv, value);
986 }
987 RETURN;
988#else
989 DIE("select not implemented");
990#endif
991}
992
4633a7c4 993void
8ac85365 994setdefout(GV *gv)
4633a7c4 995{
11343788 996 dTHR;
4633a7c4
LW
997 if (gv)
998 (void)SvREFCNT_inc(gv);
3280af22
NIS
999 if (PL_defoutgv)
1000 SvREFCNT_dec(PL_defoutgv);
1001 PL_defoutgv = gv;
4633a7c4
LW
1002}
1003
a0d0e21e
LW
1004PP(pp_select)
1005{
4e35701f 1006 djSP; dTARGET;
4633a7c4
LW
1007 GV *newdefout, *egv;
1008 HV *hv;
1009
533c011a 1010 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1011
3280af22 1012 egv = GvEGV(PL_defoutgv);
4633a7c4 1013 if (!egv)
3280af22 1014 egv = PL_defoutgv;
4633a7c4
LW
1015 hv = GvSTASH(egv);
1016 if (! hv)
3280af22 1017 XPUSHs(&PL_sv_undef);
4633a7c4 1018 else {
cbdc8872 1019 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1020 if (gvp && *gvp == egv) {
3280af22 1021 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc
PP
1022 XPUSHTARG;
1023 }
1024 else {
1025 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1026 }
4633a7c4
LW
1027 }
1028
1029 if (newdefout) {
ded8aa31
GS
1030 if (!GvIO(newdefout))
1031 gv_IOadd(newdefout);
4633a7c4
LW
1032 setdefout(newdefout);
1033 }
1034
a0d0e21e
LW
1035 RETURN;
1036}
1037
1038PP(pp_getc)
1039{
4e35701f 1040 djSP; dTARGET;
a0d0e21e 1041 GV *gv;
2ae324a7 1042 MAGIC *mg;
a0d0e21e
LW
1043
1044 if (MAXARG <= 0)
3280af22 1045 gv = PL_stdingv;
a0d0e21e
LW
1046 else
1047 gv = (GV*)POPs;
1048 if (!gv)
3280af22 1049 gv = PL_argvgv;
2ae324a7 1050
33c27489 1051 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1052 I32 gimme = GIMME_V;
2ae324a7 1053 PUSHMARK(SP);
33c27489 1054 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7
PP
1055 PUTBACK;
1056 ENTER;
54310121 1057 perl_call_method("GETC", gimme);
2ae324a7
PP
1058 LEAVE;
1059 SPAGAIN;
54310121
PP
1060 if (gimme == G_SCALAR)
1061 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7
PP
1062 RETURN;
1063 }
9bc64814 1064 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1065 RETPUSHUNDEF;
bbce6d69 1066 TAINT;
a0d0e21e 1067 sv_setpv(TARG, " ");
9bc64814 1068 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW
1069 PUSHTARG;
1070 RETURN;
1071}
1072
1073PP(pp_read)
1074{
1075 return pp_sysread(ARGS);
1076}
1077
76e3520e 1078STATIC OP *
8ac85365 1079doform(CV *cv, GV *gv, OP *retop)
a0d0e21e 1080{
11343788 1081 dTHR;
c09156bb 1082 register PERL_CONTEXT *cx;
54310121 1083 I32 gimme = GIMME_V;
a0d0e21e
LW
1084 AV* padlist = CvPADLIST(cv);
1085 SV** svp = AvARRAY(padlist);
1086
1087 ENTER;
1088 SAVETMPS;
1089
1090 push_return(retop);
3280af22 1091 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1092 PUSHFORMAT(cx);
3280af22
NIS
1093 SAVESPTR(PL_curpad);
1094 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1095
4633a7c4 1096 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW
1097 return CvSTART(cv);
1098}
1099
1100PP(pp_enterwrite)
1101{
4e35701f 1102 djSP;
a0d0e21e
LW
1103 register GV *gv;
1104 register IO *io;
1105 GV *fgv;
1106 CV *cv;
1107
1108 if (MAXARG == 0)
3280af22 1109 gv = PL_defoutgv;
a0d0e21e
LW
1110 else {
1111 gv = (GV*)POPs;
1112 if (!gv)
3280af22 1113 gv = PL_defoutgv;
a0d0e21e
LW
1114 }
1115 EXTEND(SP, 1);
1116 io = GvIO(gv);
1117 if (!io) {
1118 RETPUSHNO;
1119 }
1120 if (IoFMT_GV(io))
1121 fgv = IoFMT_GV(io);
1122 else
1123 fgv = gv;
1124
1125 cv = GvFORM(fgv);
a0d0e21e
LW
1126 if (!cv) {
1127 if (fgv) {
748a9306 1128 SV *tmpsv = sv_newmortal();
aac0dd9a 1129 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 1130 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW
1131 }
1132 DIE("Not a format reference");
1133 }
44a8e56a
PP
1134 if (CvCLONE(cv))
1135 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1136
44a8e56a 1137 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1138 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW
1139}
1140
1141PP(pp_leavewrite)
1142{
4e35701f 1143 djSP;
a0d0e21e
LW
1144 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1145 register IO *io = GvIOp(gv);
760ac839
LW
1146 PerlIO *ofp = IoOFP(io);
1147 PerlIO *fp;
a0d0e21e
LW
1148 SV **newsp;
1149 I32 gimme;
c09156bb 1150 register PERL_CONTEXT *cx;
a0d0e21e 1151
760ac839 1152 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS
1153 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1154 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1155 PL_formtarget != PL_toptarget)
a0d0e21e 1156 {
4633a7c4
LW
1157 GV *fgv;
1158 CV *cv;
a0d0e21e
LW
1159 if (!IoTOP_GV(io)) {
1160 GV *topgv;
46fc3d4c 1161 SV *topname;
a0d0e21e
LW
1162
1163 if (!IoTOP_NAME(io)) {
1164 if (!IoFMT_NAME(io))
1165 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c
PP
1166 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1167 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1168 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1169 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1170 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW
1171 else
1172 IoTOP_NAME(io) = savepv("top");
1173 }
1174 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1175 if (!topgv || !GvFORM(topgv)) {
1176 IoLINES_LEFT(io) = 100000000;
1177 goto forget_top;
1178 }
1179 IoTOP_GV(io) = topgv;
1180 }
748a9306
LW
1181 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1182 I32 lines = IoLINES_LEFT(io);
3280af22 1183 char *s = SvPVX(PL_formtarget);
8e07c86e
AD
1184 if (lines <= 0) /* Yow, header didn't even fit!!! */
1185 goto forget_top;
748a9306
LW
1186 while (lines-- > 0) {
1187 s = strchr(s, '\n');
1188 if (!s)
1189 break;
1190 s++;
1191 }
1192 if (s) {
3280af22
NIS
1193 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1194 sv_chop(PL_formtarget, s);
1195 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1196 }
1197 }
a0d0e21e 1198 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1199 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW
1200 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1201 IoPAGE(io)++;
3280af22 1202 PL_formtarget = PL_toptarget;
748a9306 1203 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW
1204 fgv = IoTOP_GV(io);
1205 if (!fgv)
1206 DIE("bad top format reference");
1207 cv = GvFORM(fgv);
1208 if (!cv) {
1209 SV *tmpsv = sv_newmortal();
aac0dd9a 1210 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW
1211 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1212 }
44a8e56a
PP
1213 if (CvCLONE(cv))
1214 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1215 return doform(cv,gv,PL_op);
a0d0e21e
LW
1216 }
1217
1218 forget_top:
3280af22 1219 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW
1220 POPFORMAT(cx);
1221 LEAVE;
1222
1223 fp = IoOFP(io);
1224 if (!fp) {
599cee73 1225 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
a0d0e21e 1226 if (IoIFP(io))
599cee73
PM
1227 warner(WARN_IO, "Filehandle only opened for input");
1228 else if (ckWARN(WARN_CLOSED))
1229 warner(WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1230 }
3280af22 1231 PUSHs(&PL_sv_no);
a0d0e21e
LW
1232 }
1233 else {
3280af22 1234 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73
PM
1235 if (ckWARN(WARN_IO))
1236 warner(WARN_IO, "page overflow");
a0d0e21e 1237 }
3280af22 1238 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1239 PerlIO_error(fp))
3280af22 1240 PUSHs(&PL_sv_no);
a0d0e21e 1241 else {
3280af22
NIS
1242 FmLINES(PL_formtarget) = 0;
1243 SvCUR_set(PL_formtarget, 0);
1244 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1245 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1246 (void)PerlIO_flush(fp);
3280af22 1247 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1248 }
1249 }
3280af22 1250 PL_formtarget = PL_bodytarget;
a0d0e21e
LW
1251 PUTBACK;
1252 return pop_return();
1253}
1254
1255PP(pp_prtf)
1256{
4e35701f 1257 djSP; dMARK; dORIGMARK;
a0d0e21e
LW
1258 GV *gv;
1259 IO *io;
760ac839 1260 PerlIO *fp;
26db47c4 1261 SV *sv;
46fc3d4c 1262 MAGIC *mg;
2d8e6c8d 1263 STRLEN n_a;
a0d0e21e 1264
533c011a 1265 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW
1266 gv = (GV*)*++MARK;
1267 else
3280af22 1268 gv = PL_defoutgv;
46fc3d4c 1269
33c27489 1270 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1271 if (MARK == ORIGMARK) {
4352c267 1272 MEXTEND(SP, 1);
46fc3d4c
PP
1273 ++MARK;
1274 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1275 ++SP;
1276 }
1277 PUSHMARK(MARK - 1);
33c27489 1278 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c
PP
1279 PUTBACK;
1280 ENTER;
1281 perl_call_method("PRINTF", G_SCALAR);
1282 LEAVE;
1283 SPAGAIN;
1284 MARK = ORIGMARK + 1;
1285 *MARK = *SP;
1286 SP = MARK;
1287 RETURN;
1288 }
1289
26db47c4 1290 sv = NEWSV(0,0);
a0d0e21e 1291 if (!(io = GvIO(gv))) {
599cee73 1292 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1293 gv_fullname3(sv, gv, Nullch);
2d8e6c8d 1294 warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW
1295 }
1296 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1297 goto just_say_no;
1298 }
1299 else if (!(fp = IoOFP(io))) {
599cee73 1300 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1301 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1302 if (IoIFP(io))
599cee73 1303 warner(WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 1304 SvPV(sv,n_a));
599cee73
PM
1305 else if (ckWARN(WARN_CLOSED))
1306 warner(WARN_CLOSED, "printf on closed filehandle %s",
2d8e6c8d 1307 SvPV(sv,n_a));
a0d0e21e 1308 }
748a9306 1309 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW
1310 goto just_say_no;
1311 }
1312 else {
36477c24 1313#ifdef USE_LOCALE_NUMERIC
533c011a 1314 if (PL_op->op_private & OPpLOCALE)
36477c24 1315 SET_NUMERIC_LOCAL();
bbce6d69 1316 else
36477c24
PP
1317 SET_NUMERIC_STANDARD();
1318#endif
a0d0e21e
LW
1319 do_sprintf(sv, SP - MARK, MARK + 1);
1320 if (!do_print(sv, fp))
1321 goto just_say_no;
1322
1323 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1324 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1325 goto just_say_no;
1326 }
1327 SvREFCNT_dec(sv);
1328 SP = ORIGMARK;
3280af22 1329 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1330 RETURN;
1331
1332 just_say_no:
1333 SvREFCNT_dec(sv);
1334 SP = ORIGMARK;
3280af22 1335 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1336 RETURN;
1337}
1338
c07a80fd
PP
1339PP(pp_sysopen)
1340{
4e35701f 1341 djSP;
c07a80fd 1342 GV *gv;
c07a80fd
PP
1343 SV *sv;
1344 char *tmps;
1345 STRLEN len;
1346 int mode, perm;
1347
1348 if (MAXARG > 3)
1349 perm = POPi;
1350 else
1351 perm = 0666;
1352 mode = POPi;
1353 sv = POPs;
1354 gv = (GV *)POPs;
1355
1356 tmps = SvPV(sv, len);
1357 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1358 IoLINES(GvIOp(gv)) = 0;
3280af22 1359 PUSHs(&PL_sv_yes);
c07a80fd
PP
1360 }
1361 else {
3280af22 1362 PUSHs(&PL_sv_undef);
c07a80fd
PP
1363 }
1364 RETURN;
1365}
1366
a0d0e21e
LW
1367PP(pp_sysread)
1368{
4e35701f 1369 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1370 int offset;
1371 GV *gv;
1372 IO *io;
1373 char *buffer;
5b54f415 1374 SSize_t length;
1e422769 1375 Sock_size_t bufsize;
748a9306 1376 SV *bufsv;
a0d0e21e 1377 STRLEN blen;
2ae324a7 1378 MAGIC *mg;
a0d0e21e
LW
1379
1380 gv = (GV*)*++MARK;
533c011a 1381 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1382 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1383 {
2ae324a7
PP
1384 SV *sv;
1385
1386 PUSHMARK(MARK-1);
33c27489 1387 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7
PP
1388 ENTER;
1389 perl_call_method("READ", G_SCALAR);
1390 LEAVE;
1391 SPAGAIN;
1392 sv = POPs;
1393 SP = ORIGMARK;
1394 PUSHs(sv);
1395 RETURN;
1396 }
1397
a0d0e21e
LW
1398 if (!gv)
1399 goto say_undef;
748a9306 1400 bufsv = *++MARK;
ff68c719
PP
1401 if (! SvOK(bufsv))
1402 sv_setpvn(bufsv, "", 0);
748a9306 1403 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW
1404 length = SvIVx(*++MARK);
1405 if (length < 0)
1406 DIE("Negative length");
748a9306 1407 SETERRNO(0,0);
a0d0e21e
LW
1408 if (MARK < SP)
1409 offset = SvIVx(*++MARK);
1410 else
1411 offset = 0;
1412 io = GvIO(gv);
1413 if (!io || !IoIFP(io))
1414 goto say_undef;
1415#ifdef HAS_SOCKET
533c011a 1416 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1417 char namebuf[MAXPATHLEN];
eec2d3df 1418#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH
1419 bufsize = sizeof (struct sockaddr_in);
1420#else
46fc3d4c 1421 bufsize = sizeof namebuf;
490ab354 1422#endif
748a9306 1423 buffer = SvGROW(bufsv, length+1);
bbce6d69 1424 /* 'offset' means 'flags' here */
6ad3d225 1425 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1426 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1427 if (length < 0)
1428 RETPUSHUNDEF;
748a9306
LW
1429 SvCUR_set(bufsv, length);
1430 *SvEND(bufsv) = '\0';
1431 (void)SvPOK_only(bufsv);
1432 SvSETMAGIC(bufsv);
aac0dd9a 1433 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1434 if (!(IoFLAGS(io) & IOf_UNTAINT))
1435 SvTAINTED_on(bufsv);
a0d0e21e 1436 SP = ORIGMARK;
46fc3d4c 1437 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1438 PUSHs(TARG);
1439 RETURN;
1440 }
1441#else
911d147d 1442 if (PL_op->op_type == OP_RECV)
22c35a8c 1443 DIE(PL_no_sock_func, "recv");
a0d0e21e 1444#endif
bbce6d69
PP
1445 if (offset < 0) {
1446 if (-offset > blen)
1447 DIE("Offset outside string");
1448 offset += blen;
1449 }
cd52b7b2 1450 bufsize = SvCUR(bufsv);
748a9306 1451 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2
PP
1452 if (offset > bufsize) { /* Zero any newly allocated space */
1453 Zero(buffer+bufsize, offset-bufsize, char);
1454 }
533c011a 1455 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS
1456#ifdef PERL_SOCK_SYSREAD_IS_RECV
1457 if (IoTYPE(io) == 's') {
1458 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1459 buffer+offset, length, 0);
1460 }
1461 else
1462#endif
1463 {
1464 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1465 buffer+offset, length);
1466 }
a0d0e21e
LW
1467 }
1468 else
1469#ifdef HAS_SOCKET__bad_code_maybe
1470 if (IoTYPE(io) == 's') {
46fc3d4c 1471 char namebuf[MAXPATHLEN];
490ab354
JH
1472#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1473 bufsize = sizeof (struct sockaddr_in);
1474#else
46fc3d4c 1475 bufsize = sizeof namebuf;
490ab354 1476#endif
6ad3d225 1477 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1478 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1479 }
1480 else
1481#endif
3b02c43c 1482 {
760ac839 1483 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1484 /* fread() returns 0 on both error and EOF */
5c7a8c78 1485 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS
1486 length = -1;
1487 }
a0d0e21e
LW
1488 if (length < 0)
1489 goto say_undef;
748a9306
LW
1490 SvCUR_set(bufsv, length+offset);
1491 *SvEND(bufsv) = '\0';
1492 (void)SvPOK_only(bufsv);
1493 SvSETMAGIC(bufsv);
aac0dd9a 1494 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1495 if (!(IoFLAGS(io) & IOf_UNTAINT))
1496 SvTAINTED_on(bufsv);
a0d0e21e
LW
1497 SP = ORIGMARK;
1498 PUSHi(length);
1499 RETURN;
1500
1501 say_undef:
1502 SP = ORIGMARK;
1503 RETPUSHUNDEF;
1504}
1505
1506PP(pp_syswrite)
1507{
092bebab
JH
1508 djSP;
1509 int items = (SP - PL_stack_base) - TOPMARK;
1510 if (items == 2) {
9f089d78 1511 SV *sv;
092bebab 1512 EXTEND(SP, 1);
9f089d78
SB
1513 sv = sv_2mortal(newSViv(sv_len(*SP)));
1514 PUSHs(sv);
092bebab
JH
1515 PUTBACK;
1516 }
a0d0e21e
LW
1517 return pp_send(ARGS);
1518}
1519
1520PP(pp_send)
1521{
4e35701f 1522 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW
1523 GV *gv;
1524 IO *io;
1525 int offset;
748a9306 1526 SV *bufsv;
a0d0e21e
LW
1527 char *buffer;
1528 int length;
1529 STRLEN blen;
1d603a67 1530 MAGIC *mg;
a0d0e21e
LW
1531
1532 gv = (GV*)*++MARK;
33c27489 1533 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB
1534 SV *sv;
1535
1536 PUSHMARK(MARK-1);
33c27489 1537 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67
GB
1538 ENTER;
1539 perl_call_method("WRITE", G_SCALAR);
1540 LEAVE;
1541 SPAGAIN;
1542 sv = POPs;
1543 SP = ORIGMARK;
1544 PUSHs(sv);
1545 RETURN;
1546 }
a0d0e21e
LW
1547 if (!gv)
1548 goto say_undef;
748a9306
LW
1549 bufsv = *++MARK;
1550 buffer = SvPV(bufsv, blen);
a0d0e21e
LW
1551 length = SvIVx(*++MARK);
1552 if (length < 0)
1553 DIE("Negative length");
748a9306 1554 SETERRNO(0,0);
a0d0e21e
LW
1555 io = GvIO(gv);
1556 if (!io || !IoIFP(io)) {
1557 length = -1;
599cee73 1558 if (ckWARN(WARN_CLOSED)) {
533c011a 1559 if (PL_op->op_type == OP_SYSWRITE)
599cee73 1560 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1561 else
599cee73 1562 warner(WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW
1563 }
1564 }
533c011a 1565 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1566 if (MARK < SP) {
a0d0e21e 1567 offset = SvIVx(*++MARK);
bbce6d69
PP
1568 if (offset < 0) {
1569 if (-offset > blen)
1570 DIE("Offset outside string");
1571 offset += blen;
fb73857a 1572 } else if (offset >= blen && blen > 0)
bbce6d69
PP
1573 DIE("Offset outside string");
1574 } else
a0d0e21e
LW
1575 offset = 0;
1576 if (length > blen - offset)
1577 length = blen - offset;
a7092146
GS
1578#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1579 if (IoTYPE(io) == 's') {
1580 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1581 buffer+offset, length, 0);
1582 }
1583 else
1584#endif
1585 {
1586 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1587 buffer+offset, length);
1588 }
a0d0e21e
LW
1589 }
1590#ifdef HAS_SOCKET
1591 else if (SP > MARK) {
1592 char *sockbuf;
1593 STRLEN mlen;
1594 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1595 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW
1596 (struct sockaddr *)sockbuf, mlen);
1597 }
1598 else
6ad3d225 1599 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1600
a0d0e21e
LW
1601#else
1602 else
22c35a8c 1603 DIE(PL_no_sock_func, "send");
a0d0e21e
LW
1604#endif
1605 if (length < 0)
1606 goto say_undef;
1607 SP = ORIGMARK;
1608 PUSHi(length);
1609 RETURN;
1610
1611 say_undef:
1612 SP = ORIGMARK;
1613 RETPUSHUNDEF;
1614}
1615
1616PP(pp_recv)
1617{
1618 return pp_sysread(ARGS);
1619}
1620
1621PP(pp_eof)
1622{
4e35701f 1623 djSP;
a0d0e21e
LW
1624 GV *gv;
1625
1626 if (MAXARG <= 0)
3280af22 1627 gv = PL_last_in_gv;
a0d0e21e 1628 else
3280af22 1629 gv = PL_last_in_gv = (GV*)POPs;
54310121 1630 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW
1631 RETURN;
1632}
1633
1634PP(pp_tell)
1635{
4e35701f 1636 djSP; dTARGET;
a0d0e21e
LW
1637 GV *gv;
1638
1639 if (MAXARG <= 0)
3280af22 1640 gv = PL_last_in_gv;
a0d0e21e 1641 else
3280af22 1642 gv = PL_last_in_gv = (GV*)POPs;
a0d0e21e
LW
1643 PUSHi( do_tell(gv) );
1644 RETURN;
1645}
1646
1647PP(pp_seek)
1648{
137443ea
PP
1649 return pp_sysseek(ARGS);
1650}
1651
1652PP(pp_sysseek)
1653{
4e35701f 1654 djSP;
a0d0e21e
LW
1655 GV *gv;
1656 int whence = POPi;
97cc44eb 1657 Off_t offset = POPl;
a0d0e21e 1658
3280af22 1659 gv = PL_last_in_gv = (GV*)POPs;
533c011a 1660 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
1661 PUSHs(boolSV(do_seek(gv, offset, whence)));
1662 else {
97cc44eb 1663 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1664 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1665 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1666 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1667 }
a0d0e21e
LW
1668 RETURN;
1669}
1670
1671PP(pp_truncate)
1672{
4e35701f 1673 djSP;
a0d0e21e
LW
1674 Off_t len = (Off_t)POPn;
1675 int result = 1;
1676 GV *tmpgv;
2d8e6c8d 1677 STRLEN n_a;
a0d0e21e 1678
748a9306 1679 SETERRNO(0,0);
5d94fbed 1680#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1681 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1682 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1683 do_ftruncate:
1e422769 1684 TAINT_PROPER("truncate");
a0d0e21e 1685 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1686#ifdef HAS_TRUNCATE
760ac839 1687 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1688#else
760ac839 1689 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1690#endif
a0d0e21e
LW
1691 result = 0;
1692 }
1693 else {
cbdc8872 1694 SV *sv = POPs;
1e422769 1695 char *name;
2d8e6c8d 1696 STRLEN n_a;
1e422769 1697
cbdc8872
PP
1698 if (SvTYPE(sv) == SVt_PVGV) {
1699 tmpgv = (GV*)sv; /* *main::FRED for example */
1700 goto do_ftruncate;
1701 }
1702 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1703 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1704 goto do_ftruncate;
1705 }
1e422769 1706
2d8e6c8d 1707 name = SvPV(sv, n_a);
1e422769 1708 TAINT_PROPER("truncate");
cbdc8872 1709#ifdef HAS_TRUNCATE
1e422769 1710 if (truncate(name, len) < 0)
a0d0e21e 1711 result = 0;
cbdc8872
PP
1712#else
1713 {
1714 int tmpfd;
6ad3d225 1715 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1716 result = 0;
cbdc8872
PP
1717 else {
1718 if (my_chsize(tmpfd, len) < 0)
1719 result = 0;
6ad3d225 1720 PerlLIO_close(tmpfd);
cbdc8872 1721 }
a0d0e21e 1722 }
a0d0e21e 1723#endif
cbdc8872 1724 }
a0d0e21e
LW
1725
1726 if (result)
1727 RETPUSHYES;
1728 if (!errno)
748a9306 1729 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
1730 RETPUSHUNDEF;
1731#else
1732 DIE("truncate not implemented");
1733#endif
1734}
1735
1736PP(pp_fcntl)
1737{
1738 return pp_ioctl(ARGS);
1739}
1740
1741PP(pp_ioctl)
1742{
4e35701f 1743 djSP; dTARGET;
748a9306 1744 SV *argsv = POPs;
a0d0e21e 1745 unsigned int func = U_I(POPn);
533c011a 1746 int optype = PL_op->op_type;
a0d0e21e 1747 char *s;
324aa91a 1748 IV retval;
a0d0e21e
LW
1749 GV *gv = (GV*)POPs;
1750 IO *io = GvIOn(gv);
1751
748a9306
LW
1752 if (!io || !argsv || !IoIFP(io)) {
1753 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW
1754 RETPUSHUNDEF;
1755 }
1756
748a9306 1757 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1758 STRLEN len;
324aa91a 1759 STRLEN need;
748a9306 1760 s = SvPV_force(argsv, len);
324aa91a
HF
1761 need = IOCPARM_LEN(func);
1762 if (len < need) {
1763 s = Sv_Grow(argsv, need + 1);
1764 SvCUR_set(argsv, need);
a0d0e21e
LW
1765 }
1766
748a9306 1767 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
1768 }
1769 else {
748a9306 1770 retval = SvIV(argsv);
a0d0e21e 1771 s = (char*)retval; /* ouch */
a0d0e21e
LW
1772 }
1773
1774 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1775
1776 if (optype == OP_IOCTL)
1777#ifdef HAS_IOCTL
76e3520e 1778 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e
LW
1779#else
1780 DIE("ioctl is not implemented");
1781#endif
1782 else
55497cff
PP
1783#ifdef HAS_FCNTL
1784#if defined(OS2) && defined(__EMX__)
760ac839 1785 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1786#else
760ac839 1787 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff
PP
1788#endif
1789#else
a0d0e21e 1790 DIE("fcntl is not implemented");
a0d0e21e
LW
1791#endif
1792
748a9306
LW
1793 if (SvPOK(argsv)) {
1794 if (s[SvCUR(argsv)] != 17)
a0d0e21e 1795 DIE("Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1796 PL_op_name[optype]);
748a9306
LW
1797 s[SvCUR(argsv)] = 0; /* put our null back */
1798 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
1799 }
1800
1801 if (retval == -1)
1802 RETPUSHUNDEF;
1803 if (retval != 0) {
1804 PUSHi(retval);
1805 }
1806 else {
8903cb82 1807 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW
1808 }
1809 RETURN;
1810}
1811
1812PP(pp_flock)
1813{
4e35701f 1814 djSP; dTARGET;
a0d0e21e
LW
1815 I32 value;
1816 int argtype;
1817 GV *gv;
760ac839 1818 PerlIO *fp;
16d20bd9 1819
ff68c719 1820#ifdef FLOCK
a0d0e21e
LW
1821 argtype = POPi;
1822 if (MAXARG <= 0)
3280af22 1823 gv = PL_last_in_gv;
a0d0e21e
LW
1824 else
1825 gv = (GV*)POPs;
1826 if (gv && GvIO(gv))
1827 fp = IoIFP(GvIOp(gv));
1828 else
1829 fp = Nullfp;
1830 if (fp) {
68dc0745 1831 (void)PerlIO_flush(fp);
76e3520e 1832 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW
1833 }
1834 else
1835 value = 0;
1836 PUSHi(value);
1837 RETURN;
1838#else
22c35a8c 1839 DIE(PL_no_func, "flock()");
a0d0e21e
LW
1840#endif
1841}
1842
1843/* Sockets. */
1844
1845PP(pp_socket)
1846{
4e35701f 1847 djSP;
a0d0e21e
LW
1848#ifdef HAS_SOCKET
1849 GV *gv;
1850 register IO *io;
1851 int protocol = POPi;
1852 int type = POPi;
1853 int domain = POPi;
1854 int fd;
1855
1856 gv = (GV*)POPs;
1857
1858 if (!gv) {
748a9306 1859 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW
1860 RETPUSHUNDEF;
1861 }
1862
1863 io = GvIOn(gv);
1864 if (IoIFP(io))
1865 do_close(gv, FALSE);
1866
1867 TAINT_PROPER("socket");
6ad3d225 1868 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW
1869 if (fd < 0)
1870 RETPUSHUNDEF;
760ac839
LW
1871 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1872 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW
1873 IoTYPE(io) = 's';
1874 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
1875 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1876 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1877 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
1878 RETPUSHUNDEF;
1879 }
1880
1881 RETPUSHYES;
1882#else
22c35a8c 1883 DIE(PL_no_sock_func, "socket");
a0d0e21e
LW
1884#endif
1885}
1886
1887PP(pp_sockpair)
1888{
4e35701f 1889 djSP;
a0d0e21e
LW
1890#ifdef HAS_SOCKETPAIR
1891 GV *gv1;
1892 GV *gv2;
1893 register IO *io1;
1894 register IO *io2;
1895 int protocol = POPi;
1896 int type = POPi;
1897 int domain = POPi;
1898 int fd[2];
1899
1900 gv2 = (GV*)POPs;
1901 gv1 = (GV*)POPs;
1902 if (!gv1 || !gv2)
1903 RETPUSHUNDEF;
1904
1905 io1 = GvIOn(gv1);
1906 io2 = GvIOn(gv2);
1907 if (IoIFP(io1))
1908 do_close(gv1, FALSE);
1909 if (IoIFP(io2))
1910 do_close(gv2, FALSE);
1911
1912 TAINT_PROPER("socketpair");
6ad3d225 1913 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 1914 RETPUSHUNDEF;
760ac839
LW
1915 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
1916 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 1917 IoTYPE(io1) = 's';
760ac839
LW
1918 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
1919 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW
1920 IoTYPE(io2) = 's';
1921 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW
1922 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
1923 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 1924 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW
1925 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
1926 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 1927 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW
1928 RETPUSHUNDEF;
1929 }
1930
1931 RETPUSHYES;
1932#else
22c35a8c 1933 DIE(PL_no_sock_func, "socketpair");
a0d0e21e
LW
1934#endif
1935}
1936
1937PP(pp_bind)
1938{
4e35701f 1939 djSP;
a0d0e21e 1940#ifdef HAS_SOCKET
eec2d3df
GS
1941#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
1942 extern GETPRIVMODE();
1943 extern GETUSERMODE();
1944#endif
748a9306 1945 SV *addrsv = POPs;
a0d0e21e
LW
1946 char *addr;
1947 GV *gv = (GV*)POPs;
1948 register IO *io = GvIOn(gv);
1949 STRLEN len;
eec2d3df
GS
1950 int bind_ok = 0;
1951#ifdef MPE
1952 int mpeprivmode = 0;
1953#endif
a0d0e21e
LW
1954
1955 if (!io || !IoIFP(io))
1956 goto nuts;
1957
748a9306 1958 addr = SvPV(addrsv, len);
a0d0e21e 1959 TAINT_PROPER("bind");
eec2d3df
GS
1960#ifdef MPE /* Deal with MPE bind() peculiarities */
1961 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
1962 /* The address *MUST* stupidly be zero. */
1963 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
1964 /* PRIV mode is required to bind() to ports < 1024. */
1965 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
1966 ((struct sockaddr_in *)addr)->sin_port > 0) {
1967 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
1968 mpeprivmode = 1;
1969 }
1970 }
1971#endif /* MPE */
1972 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
1973 (struct sockaddr *)addr, len) >= 0)
1974 bind_ok = 1;
1975
1976#ifdef MPE /* Switch back to USER mode */
1977 if (mpeprivmode)
1978 GETUSERMODE();
1979#endif /* MPE */
1980
1981 if (bind_ok)
a0d0e21e
LW
1982 RETPUSHYES;
1983 else
1984 RETPUSHUNDEF;
1985
1986nuts:
599cee73
PM
1987 if (ckWARN(WARN_CLOSED))
1988 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 1989 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
1990 RETPUSHUNDEF;
1991#else
22c35a8c 1992 DIE(PL_no_sock_func, "bind");
a0d0e21e
LW
1993#endif
1994}
1995
1996PP(pp_connect)
1997{
4e35701f 1998 djSP;
a0d0e21e 1999#ifdef HAS_SOCKET
748a9306 2000 SV *addrsv = POPs;
a0d0e21e
LW
2001 char *addr;
2002 GV *gv = (GV*)POPs;
2003 register IO *io = GvIOn(gv);
2004 STRLEN len;
2005
2006 if (!io || !IoIFP(io))
2007 goto nuts;
2008
748a9306 2009 addr = SvPV(addrsv, len);
a0d0e21e 2010 TAINT_PROPER("connect");
6ad3d225 2011 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW
2012 RETPUSHYES;
2013 else
2014 RETPUSHUNDEF;
2015
2016nuts:
599cee73
PM
2017 if (ckWARN(WARN_CLOSED))
2018 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 2019 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2020 RETPUSHUNDEF;
2021#else
22c35a8c 2022 DIE(PL_no_sock_func, "connect");
a0d0e21e
LW
2023#endif
2024}
2025
2026PP(pp_listen)
2027{
4e35701f 2028 djSP;
a0d0e21e
LW
2029#ifdef HAS_SOCKET
2030 int backlog = POPi;
2031 GV *gv = (GV*)POPs;
2032 register IO *io = GvIOn(gv);
2033
2034 if (!io || !IoIFP(io))
2035 goto nuts;
2036
6ad3d225 2037 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW
2038 RETPUSHYES;
2039 else
2040 RETPUSHUNDEF;
2041
2042nuts:
599cee73
PM
2043 if (ckWARN(WARN_CLOSED))
2044 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 2045 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2046 RETPUSHUNDEF;
2047#else
22c35a8c 2048 DIE(PL_no_sock_func, "listen");
a0d0e21e
LW
2049#endif
2050}
2051
2052PP(pp_accept)
2053{
4e35701f 2054 djSP; dTARGET;
a0d0e21e
LW
2055#ifdef HAS_SOCKET
2056 GV *ngv;
2057 GV *ggv;
2058 register IO *nstio;
2059 register IO *gstio;
4633a7c4 2060 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2061 Sock_size_t len = sizeof saddr;
a0d0e21e
LW
2062 int fd;
2063
2064 ggv = (GV*)POPs;
2065 ngv = (GV*)POPs;
2066
2067 if (!ngv)
2068 goto badexit;
2069 if (!ggv)
2070 goto nuts;
2071
2072 gstio = GvIO(ggv);
2073 if (!gstio || !IoIFP(gstio))
2074 goto nuts;
2075
2076 nstio = GvIOn(ngv);
2077 if (IoIFP(nstio))
2078 do_close(ngv, FALSE);
2079
6ad3d225 2080 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW
2081 if (fd < 0)
2082 goto badexit;
760ac839
LW
2083 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2084 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW
2085 IoTYPE(nstio) = 's';
2086 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW
2087 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2088 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2089 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW
2090 goto badexit;
2091 }
2092
748a9306 2093 PUSHp((char *)&saddr, len);
a0d0e21e
LW
2094 RETURN;
2095
2096nuts:
599cee73
PM
2097 if (ckWARN(WARN_CLOSED))
2098 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2099 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2100
2101badexit:
2102 RETPUSHUNDEF;
2103
2104#else
22c35a8c 2105 DIE(PL_no_sock_func, "accept");
a0d0e21e
LW
2106#endif
2107}
2108
2109PP(pp_shutdown)
2110{
4e35701f 2111 djSP; dTARGET;
a0d0e21e
LW
2112#ifdef HAS_SOCKET
2113 int how = POPi;
2114 GV *gv = (GV*)POPs;
2115 register IO *io = GvIOn(gv);
2116
2117 if (!io || !IoIFP(io))
2118 goto nuts;
2119
6ad3d225 2120 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW
2121 RETURN;
2122
2123nuts:
599cee73
PM
2124 if (ckWARN(WARN_CLOSED))
2125 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2126 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2127 RETPUSHUNDEF;
2128#else
22c35a8c 2129 DIE(PL_no_sock_func, "shutdown");
a0d0e21e
LW
2130#endif
2131}
2132
2133PP(pp_gsockopt)
2134{
2135#ifdef HAS_SOCKET
2136 return pp_ssockopt(ARGS);
2137#else
22c35a8c 2138 DIE(PL_no_sock_func, "getsockopt");
a0d0e21e
LW
2139#endif
2140}
2141
2142PP(pp_ssockopt)
2143{
4e35701f 2144 djSP;
a0d0e21e 2145#ifdef HAS_SOCKET
533c011a 2146 int optype = PL_op->op_type;
a0d0e21e
LW
2147 SV *sv;
2148 int fd;
2149 unsigned int optname;
2150 unsigned int lvl;
2151 GV *gv;
2152 register IO *io;
1e422769 2153 Sock_size_t len;
a0d0e21e
LW
2154
2155 if (optype == OP_GSOCKOPT)
2156 sv = sv_2mortal(NEWSV(22, 257));
2157 else
2158 sv = POPs;
2159 optname = (unsigned int) POPi;
2160 lvl = (unsigned int) POPi;
2161
2162 gv = (GV*)POPs;
2163 io = GvIOn(gv);
2164 if (!io || !IoIFP(io))
2165 goto nuts;
2166
760ac839 2167 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2168 switch (optype) {
2169 case OP_GSOCKOPT:
748a9306 2170 SvGROW(sv, 257);
a0d0e21e 2171 (void)SvPOK_only(sv);
748a9306
LW
2172 SvCUR_set(sv,256);
2173 *SvEND(sv) ='\0';
1e422769 2174 len = SvCUR(sv);
6ad3d225 2175 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2176 goto nuts2;
1e422769 2177 SvCUR_set(sv, len);
748a9306 2178 *SvEND(sv) ='\0';
a0d0e21e
LW
2179 PUSHs(sv);
2180 break;
2181 case OP_SSOCKOPT: {
1e422769
PP
2182 char *buf;
2183 int aint;
2184 if (SvPOKp(sv)) {
2d8e6c8d
GS
2185 STRLEN l;
2186 buf = SvPV(sv, l);
2187 len = l;
1e422769 2188 }
56ee1660 2189 else {
a0d0e21e
LW
2190 aint = (int)SvIV(sv);
2191 buf = (char*)&aint;
2192 len = sizeof(int);
2193 }
6ad3d225 2194 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2195 goto nuts2;
3280af22 2196 PUSHs(&PL_sv_yes);
a0d0e21e
LW
2197 }
2198 break;
2199 }
2200 RETURN;
2201
2202nuts:
599cee73
PM
2203 if (ckWARN(WARN_CLOSED))
2204 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2205 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2206nuts2:
2207 RETPUSHUNDEF;
2208
2209#else
22c35a8c 2210 DIE(PL_no_sock_func, "setsockopt");
a0d0e21e
LW
2211#endif
2212}
2213
2214PP(pp_getsockname)
2215{
2216#ifdef HAS_SOCKET
2217 return pp_getpeername(ARGS);
2218#else
22c35a8c 2219 DIE(PL_no_sock_func, "getsockname");
a0d0e21e
LW
2220#endif
2221}
2222
2223PP(pp_getpeername)
2224{
4e35701f 2225 djSP;
a0d0e21e 2226#ifdef HAS_SOCKET
533c011a 2227 int optype = PL_op->op_type;
a0d0e21e
LW
2228 SV *sv;
2229 int fd;
2230 GV *gv = (GV*)POPs;
2231 register IO *io = GvIOn(gv);
1e422769 2232 Sock_size_t len;
a0d0e21e
LW
2233
2234 if (!io || !IoIFP(io))
2235 goto nuts;
2236
2237 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2238 (void)SvPOK_only(sv);
1e422769
PP
2239 len = 256;
2240 SvCUR_set(sv, len);
748a9306 2241 *SvEND(sv) ='\0';
760ac839 2242 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2243 switch (optype) {
2244 case OP_GETSOCKNAME:
6ad3d225 2245 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW
2246 goto nuts2;
2247 break;
2248 case OP_GETPEERNAME:
6ad3d225 2249 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2250 goto nuts2;
490ab354
JH
2251#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2252 {
2253 static const char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
2254 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2255 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2256 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2257 sizeof(u_short) + sizeof(struct in_addr))) {
2258 goto nuts2;
2259 }
2260 }
2261#endif
a0d0e21e
LW
2262 break;
2263 }
13826f2c
CS
2264#ifdef BOGUS_GETNAME_RETURN
2265 /* Interactive Unix, getpeername() and getsockname()
2266 does not return valid namelen */
1e422769
PP
2267 if (len == BOGUS_GETNAME_RETURN)
2268 len = sizeof(struct sockaddr);
13826f2c 2269#endif
1e422769 2270 SvCUR_set(sv, len);
748a9306 2271 *SvEND(sv) ='\0';
a0d0e21e
LW
2272 PUSHs(sv);
2273 RETURN;
2274
2275nuts:
599cee73
PM
2276 if (ckWARN(WARN_CLOSED))
2277 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2278 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW
2279nuts2:
2280 RETPUSHUNDEF;
2281
2282#else
22c35a8c 2283 DIE(PL_no_sock_func, "getpeername");
a0d0e21e
LW
2284#endif
2285}
2286
2287/* Stat calls. */
2288
2289PP(pp_lstat)
2290{
2291 return pp_stat(ARGS);
2292}
2293
2294PP(pp_stat)
2295{
4e35701f 2296 djSP;
a0d0e21e 2297 GV *tmpgv;
54310121 2298 I32 gimme;
a0d0e21e 2299 I32 max = 13;
2d8e6c8d 2300 STRLEN n_a;
a0d0e21e 2301
533c011a 2302 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2303 tmpgv = cGVOP->op_gv;
748a9306 2304 do_fstat:
3280af22
NIS
2305 if (tmpgv != PL_defgv) {
2306 PL_laststype = OP_STAT;
2307 PL_statgv = tmpgv;
2308 sv_setpv(PL_statname, "");
2309 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2310 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2311 }
3280af22 2312 if (PL_laststatval < 0)
a0d0e21e
LW
2313 max = 0;
2314 }
2315 else {
748a9306
LW
2316 SV* sv = POPs;
2317 if (SvTYPE(sv) == SVt_PVGV) {
2318 tmpgv = (GV*)sv;
2319 goto do_fstat;
2320 }
2321 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2322 tmpgv = (GV*)SvRV(sv);
2323 goto do_fstat;
2324 }
2d8e6c8d 2325 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2326 PL_statgv = Nullgv;
a0d0e21e 2327#ifdef HAS_LSTAT
533c011a
NIS
2328 PL_laststype = PL_op->op_type;
2329 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2330 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW
2331 else
2332#endif
2d8e6c8d 2333 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2334 if (PL_laststatval < 0) {
2d8e6c8d 2335 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
22c35a8c 2336 warner(WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW
2337 max = 0;
2338 }
2339 }
2340
54310121
PP
2341 gimme = GIMME_V;
2342 if (gimme != G_ARRAY) {
2343 if (gimme != G_VOID)
2344 XPUSHs(boolSV(max));
2345 RETURN;
a0d0e21e
LW
2346 }
2347 if (max) {
36477c24
PP
2348 EXTEND(SP, max);
2349 EXTEND_MORTAL(max);
3280af22
NIS
2350 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2351 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2352 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2353 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2354 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2355 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2356#ifdef USE_STAT_RDEV
3280af22 2357 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2358#else
79cb57f6 2359 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2360#endif
3280af22 2361 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2362#ifdef BIG_TIME
6b88bc9c
GS
2363 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2364 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2365 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2366#else
3280af22
NIS
2367 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2368 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2369 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2370#endif
a0d0e21e 2371#ifdef USE_STAT_BLOCKS
3280af22
NIS
2372 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2373 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e 2374#else
79cb57f6
GS
2375 PUSHs(sv_2mortal(newSVpvn("", 0)));
2376 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW
2377#endif
2378 }
2379 RETURN;
2380}
2381
2382PP(pp_ftrread)
2383{
5ff3f7a4 2384 I32 result;
4e35701f 2385 djSP;
5ff3f7a4 2386#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2387 STRLEN n_a;
5ff3f7a4 2388 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2389 result = access(TOPpx, R_OK);
5ff3f7a4
GS
2390 if (result == 0)
2391 RETPUSHYES;
2392 if (result < 0)
2393 RETPUSHUNDEF;
2394 RETPUSHNO;
22865c03
GS
2395 }
2396 else
5ff3f7a4
GS
2397 result = my_stat(ARGS);
2398#else
2399 result = my_stat(ARGS);
2400#endif
22865c03 2401 SPAGAIN;
a0d0e21e
LW
2402 if (result < 0)
2403 RETPUSHUNDEF;
3280af22 2404 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW
2405 RETPUSHYES;
2406 RETPUSHNO;
2407}
2408
2409PP(pp_ftrwrite)
2410{
5ff3f7a4 2411 I32 result;
4e35701f 2412 djSP;
5ff3f7a4 2413#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2414 STRLEN n_a;
5ff3f7a4 2415 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2416 result = access(TOPpx, W_OK);
5ff3f7a4
GS
2417 if (result == 0)
2418 RETPUSHYES;
2419 if (result < 0)
2420 RETPUSHUNDEF;
2421 RETPUSHNO;
22865c03
GS
2422 }
2423 else
5ff3f7a4
GS
2424 result = my_stat(ARGS);
2425#else
2426 result = my_stat(ARGS);
2427#endif
22865c03 2428 SPAGAIN;
a0d0e21e
LW
2429 if (result < 0)
2430 RETPUSHUNDEF;
3280af22 2431 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW
2432 RETPUSHYES;
2433 RETPUSHNO;
2434}
2435
2436PP(pp_ftrexec)
2437{
5ff3f7a4 2438 I32 result;
4e35701f 2439 djSP;
5ff3f7a4 2440#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2441 STRLEN n_a;
5ff3f7a4 2442 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2443 result = access(TOPpx, X_OK);
5ff3f7a4
GS
2444 if (result == 0)
2445 RETPUSHYES;
2446 if (result < 0)
2447 RETPUSHUNDEF;
2448 RETPUSHNO;
22865c03
GS
2449 }
2450 else
5ff3f7a4
GS
2451 result = my_stat(ARGS);
2452#else
2453 result = my_stat(ARGS);
2454#endif
22865c03 2455 SPAGAIN;
a0d0e21e
LW
2456 if (result < 0)
2457 RETPUSHUNDEF;
3280af22 2458 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW
2459 RETPUSHYES;
2460 RETPUSHNO;
2461}
2462
2463PP(pp_fteread)
2464{
5ff3f7a4 2465 I32 result;
4e35701f 2466 djSP;
5ff3f7a4 2467#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2468 STRLEN n_a;
5ff3f7a4 2469 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2470 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS
2471 if (result == 0)
2472 RETPUSHYES;
2473 if (result < 0)
2474 RETPUSHUNDEF;
2475 RETPUSHNO;
22865c03
GS
2476 }
2477 else
5ff3f7a4
GS
2478 result = my_stat(ARGS);
2479#else
2480 result = my_stat(ARGS);
2481#endif
22865c03 2482 SPAGAIN;
a0d0e21e
LW
2483 if (result < 0)
2484 RETPUSHUNDEF;
3280af22 2485 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW
2486 RETPUSHYES;
2487 RETPUSHNO;
2488}
2489
2490PP(pp_ftewrite)
2491{
5ff3f7a4 2492 I32 result;
4e35701f 2493 djSP;
5ff3f7a4 2494#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2495 STRLEN n_a;
5ff3f7a4 2496 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2497 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS
2498 if (result == 0)
2499 RETPUSHYES;
2500 if (result < 0)
2501 RETPUSHUNDEF;
2502 RETPUSHNO;
22865c03
GS
2503 }
2504 else
5ff3f7a4
GS
2505 result = my_stat(ARGS);
2506#else
2507 result = my_stat(ARGS);
2508#endif
22865c03 2509 SPAGAIN;
a0d0e21e
LW
2510 if (result < 0)
2511 RETPUSHUNDEF;
3280af22 2512 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW
2513 RETPUSHYES;
2514 RETPUSHNO;
2515}
2516
2517PP(pp_fteexec)
2518{
5ff3f7a4 2519 I32 result;
4e35701f 2520 djSP;
5ff3f7a4 2521#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2522 STRLEN n_a;
5ff3f7a4 2523 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2524 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS
2525 if (result == 0)
2526 RETPUSHYES;
2527 if (result < 0)
2528 RETPUSHUNDEF;
2529 RETPUSHNO;
22865c03
GS
2530 }
2531 else
5ff3f7a4
GS
2532 result = my_stat(ARGS);
2533#else
2534 result = my_stat(ARGS);
2535#endif
22865c03 2536 SPAGAIN;
a0d0e21e
LW
2537 if (result < 0)
2538 RETPUSHUNDEF;
3280af22 2539 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW
2540 RETPUSHYES;
2541 RETPUSHNO;
2542}
2543
2544PP(pp_ftis)
2545{
2546 I32 result = my_stat(ARGS);
4e35701f 2547 djSP;
a0d0e21e
LW
2548 if (result < 0)
2549 RETPUSHUNDEF;
2550 RETPUSHYES;
2551}
2552
2553PP(pp_fteowned)
2554{
2555 return pp_ftrowned(ARGS);
2556}
2557
2558PP(pp_ftrowned)
2559{
2560 I32 result = my_stat(ARGS);
4e35701f 2561 djSP;
a0d0e21e
LW
2562 if (result < 0)
2563 RETPUSHUNDEF;
533c011a 2564 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW
2565 RETPUSHYES;
2566 RETPUSHNO;
2567}
2568
2569PP(pp_ftzero)
2570{
2571 I32 result = my_stat(ARGS);
4e35701f 2572 djSP;
a0d0e21e
LW
2573 if (result < 0)
2574 RETPUSHUNDEF;
3280af22 2575 if (!PL_statcache.st_size)
a0d0e21e
LW
2576 RETPUSHYES;
2577 RETPUSHNO;
2578}
2579
2580PP(pp_ftsize)
2581{
2582 I32 result = my_stat(ARGS);
4e35701f 2583 djSP; dTARGET;
a0d0e21e
LW
2584 if (result < 0)
2585 RETPUSHUNDEF;
3280af22 2586 PUSHi(PL_statcache.st_size);
a0d0e21e
LW
2587 RETURN;
2588}
2589
2590PP(pp_ftmtime)
2591{
2592 I32 result = my_stat(ARGS);
4e35701f 2593 djSP; dTARGET;
a0d0e21e
LW
2594 if (result < 0)
2595 RETPUSHUNDEF;
3280af22 2596 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW
2597 RETURN;
2598}
2599
2600PP(pp_ftatime)
2601{
2602 I32 result = my_stat(ARGS);
4e35701f 2603 djSP; dTARGET;
a0d0e21e
LW
2604 if (result < 0)
2605 RETPUSHUNDEF;
3280af22 2606 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW
2607 RETURN;
2608}
2609
2610PP(pp_ftctime)
2611{
2612 I32 result = my_stat(ARGS);
4e35701f 2613 djSP; dTARGET;
a0d0e21e
LW
2614 if (result < 0)
2615 RETPUSHUNDEF;
3280af22 2616 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW
2617 RETURN;
2618}
2619
2620PP(pp_ftsock)
2621{
2622 I32 result = my_stat(ARGS);
4e35701f 2623 djSP;
a0d0e21e
LW
2624 if (result < 0)
2625 RETPUSHUNDEF;
3280af22 2626 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW
2627 RETPUSHYES;
2628 RETPUSHNO;
2629}
2630
2631PP(pp_ftchr)
2632{
2633 I32 result = my_stat(ARGS);
4e35701f 2634 djSP;
a0d0e21e
LW
2635 if (result < 0)
2636 RETPUSHUNDEF;
3280af22 2637 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW
2638 RETPUSHYES;
2639 RETPUSHNO;
2640}
2641
2642PP(pp_ftblk)
2643{
2644 I32 result = my_stat(ARGS);
4e35701f 2645 djSP;
a0d0e21e
LW
2646 if (result < 0)
2647 RETPUSHUNDEF;
3280af22 2648 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW
2649 RETPUSHYES;
2650 RETPUSHNO;
2651}
2652
2653PP(pp_ftfile)
2654{
2655 I32 result = my_stat(ARGS);
4e35701f 2656 djSP;
a0d0e21e
LW
2657 if (result < 0)
2658 RETPUSHUNDEF;
3280af22 2659 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW
2660 RETPUSHYES;
2661 RETPUSHNO;
2662}
2663
2664PP(pp_ftdir)
2665{
2666 I32 result = my_stat(ARGS);
4e35701f 2667 djSP;
a0d0e21e
LW
2668 if (result < 0)
2669 RETPUSHUNDEF;
3280af22 2670 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW
2671 RETPUSHYES;
2672 RETPUSHNO;
2673}
2674
2675PP(pp_ftpipe)
2676{
2677 I32 result = my_stat(ARGS);
4e35701f 2678 djSP;
a0d0e21e
LW
2679 if (result < 0)
2680 RETPUSHUNDEF;
3280af22 2681 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW
2682 RETPUSHYES;
2683 RETPUSHNO;
2684}
2685
2686PP(pp_ftlink)
2687{
2688 I32 result = my_lstat(ARGS);
4e35701f 2689 djSP;
a0d0e21e
LW
2690 if (result < 0)
2691 RETPUSHUNDEF;
3280af22 2692 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW
2693 RETPUSHYES;
2694 RETPUSHNO;
2695}
2696
2697PP(pp_ftsuid)
2698{
4e35701f 2699 djSP;
a0d0e21e
LW
2700#ifdef S_ISUID
2701 I32 result = my_stat(ARGS);
2702 SPAGAIN;
2703 if (result < 0)
2704 RETPUSHUNDEF;
3280af22 2705 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW
2706 RETPUSHYES;
2707#endif
2708 RETPUSHNO;
2709}
2710
2711PP(pp_ftsgid)
2712{
4e35701f 2713 djSP;
a0d0e21e
LW
2714#ifdef S_ISGID
2715 I32 result = my_stat(ARGS);
2716 SPAGAIN;
2717 if (result < 0)
2718 RETPUSHUNDEF;
3280af22 2719 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW
2720 RETPUSHYES;
2721#endif
2722 RETPUSHNO;
2723}
2724
2725PP(pp_ftsvtx)
2726{
4e35701f 2727 djSP;
a0d0e21e
LW
2728#ifdef S_ISVTX
2729 I32 result = my_stat(ARGS);
2730 SPAGAIN;
2731 if (result < 0)
2732 RETPUSHUNDEF;
3280af22 2733 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW
2734 RETPUSHYES;
2735#endif
2736 RETPUSHNO;
2737}
2738
2739PP(pp_fttty)
2740{
4e35701f 2741 djSP;
a0d0e21e
LW
2742 int fd;
2743 GV *gv;
fb73857a 2744 char *tmps = Nullch;
2d8e6c8d 2745 STRLEN n_a;
fb73857a 2746
533c011a 2747 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2748 gv = cGVOP->op_gv;
fb73857a
PP
2749 else if (isGV(TOPs))
2750 gv = (GV*)POPs;
2751 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2752 gv = (GV*)SvRV(POPs);
a0d0e21e 2753 else
2d8e6c8d 2754 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2755
a0d0e21e 2756 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2757 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2758 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW
2759 fd = atoi(tmps);
2760 else
2761 RETPUSHUNDEF;
6ad3d225 2762 if (PerlLIO_isatty(fd))
a0d0e21e
LW
2763 RETPUSHYES;
2764 RETPUSHNO;
2765}
2766
16d20bd9
AD
2767#if defined(atarist) /* this will work with atariST. Configure will
2768 make guesses for other systems. */
2769# define FILE_base(f) ((f)->_base)
2770# define FILE_ptr(f) ((f)->_ptr)
2771# define FILE_cnt(f) ((f)->_cnt)
2772# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW
2773#endif
2774
2775PP(pp_fttext)
2776{
4e35701f 2777 djSP;
a0d0e21e
LW
2778 I32 i;
2779 I32 len;
2780 I32 odd = 0;
2781 STDCHAR tbuf[512];
2782 register STDCHAR *s;
2783 register IO *io;
5f05dabc
PP
2784 register SV *sv;
2785 GV *gv;
2d8e6c8d 2786 STRLEN n_a;
a0d0e21e 2787
533c011a 2788 if (PL_op->op_flags & OPf_REF)
5f05dabc
PP
2789 gv = cGVOP->op_gv;
2790 else if (isGV(TOPs))
2791 gv = (GV*)POPs;
2792 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2793 gv = (GV*)SvRV(POPs);
2794 else
2795 gv = Nullgv;
2796
2797 if (gv) {
a0d0e21e 2798 EXTEND(SP, 1);
3280af22
NIS
2799 if (gv == PL_defgv) {
2800 if (PL_statgv)
2801 io = GvIO(PL_statgv);
a0d0e21e 2802 else {
3280af22 2803 sv = PL_statname;
a0d0e21e
LW
2804 goto really_filename;
2805 }
2806 }
2807 else {
3280af22
NIS
2808 PL_statgv = gv;
2809 PL_laststatval = -1;
2810 sv_setpv(PL_statname, "");
2811 io = GvIO(PL_statgv);
a0d0e21e
LW
2812 }
2813 if (io && IoIFP(io)) {
5f05dabc
PP
2814 if (! PerlIO_has_base(IoIFP(io)))
2815 DIE("-T and -B not implemented on filehandles");
3280af22
NIS
2816 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2817 if (PL_laststatval < 0)
5f05dabc 2818 RETPUSHUNDEF;
3280af22 2819 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2820 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
2821 RETPUSHNO;
2822 else
2823 RETPUSHYES;
760ac839
LW
2824 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2825 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2826 if (i != EOF)
760ac839 2827 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2828 }
760ac839 2829 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2830 RETPUSHYES;
760ac839
LW
2831 len = PerlIO_get_bufsiz(IoIFP(io));
2832 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2833 /* sfio can have large buffers - limit to 512 */
2834 if (len > 512)
2835 len = 512;
a0d0e21e
LW
2836 }
2837 else {
599cee73
PM
2838 if (ckWARN(WARN_UNOPENED))
2839 warner(WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2840 GvENAME(cGVOP->op_gv));
748a9306 2841 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
2842 RETPUSHUNDEF;
2843 }
2844 }
2845 else {
2846 sv = POPs;
5f05dabc 2847 really_filename:
3280af22
NIS
2848 PL_statgv = Nullgv;
2849 PL_laststatval = -1;
2d8e6c8d 2850 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2851#ifdef HAS_OPEN3
2d8e6c8d 2852 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2853#else
2d8e6c8d 2854 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW
2855#endif
2856 if (i < 0) {
2d8e6c8d 2857 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
22c35a8c 2858 warner(WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW
2859 RETPUSHUNDEF;
2860 }
3280af22
NIS
2861 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2862 if (PL_laststatval < 0)
5f05dabc 2863 RETPUSHUNDEF;
6ad3d225
GS
2864 len = PerlLIO_read(i, tbuf, 512);
2865 (void)PerlLIO_close(i);
a0d0e21e 2866 if (len <= 0) {
533c011a 2867 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
2868 RETPUSHNO; /* special case NFS directories */
2869 RETPUSHYES; /* null file is anything */
2870 }
2871 s = tbuf;
2872 }
2873
2874 /* now scan s to look for textiness */
4633a7c4 2875 /* XXX ASCII dependent code */
a0d0e21e
LW
2876
2877 for (i = 0; i < len; i++, s++) {
2878 if (!*s) { /* null never allowed in text */
2879 odd += len;
2880 break;
2881 }
9d116dd7
JH
2882#ifdef EBCDIC
2883 else if (!(isPRINT(*s) || isSPACE(*s)))
2884 odd++;
2885#else
a0d0e21e
LW
2886 else if (*s & 128)
2887 odd++;
2888 else if (*s < 32 &&
2889 *s != '\n' && *s != '\r' && *s != '\b' &&
2890 *s != '\t' && *s != '\f' && *s != 27)
2891 odd++;
9d116dd7 2892#endif
a0d0e21e
LW
2893 }
2894
533c011a 2895 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW
2896 RETPUSHNO;
2897 else
2898 RETPUSHYES;
2899}
2900
2901PP(pp_ftbinary)
2902{
2903 return pp_fttext(ARGS);
2904}
2905
2906/* File calls. */
2907
2908PP(pp_chdir)
2909{
4e35701f 2910 djSP; dTARGET;
a0d0e21e
LW
2911 char *tmps;
2912 SV **svp;
2d8e6c8d 2913 STRLEN n_a;
a0d0e21e
LW
2914
2915 if (MAXARG < 1)
2916 tmps = Nullch;
2917 else
2d8e6c8d 2918 tmps = POPpx;
a0d0e21e 2919 if (!tmps || !*tmps) {
3280af22 2920 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 2921 if (svp)
2d8e6c8d 2922 tmps = SvPV(*svp, n_a);
a0d0e21e
LW
2923 }
2924 if (!tmps || !*tmps) {
3280af22 2925 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 2926 if (svp)
2d8e6c8d 2927 tmps = SvPV(*svp, n_a);
a0d0e21e 2928 }
491527d0
GS
2929#ifdef VMS
2930 if (!tmps || !*tmps) {
6b88bc9c 2931 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 2932 if (svp)
2d8e6c8d 2933 tmps = SvPV(*svp, n_a);
491527d0
GS
2934 }
2935#endif
a0d0e21e 2936 TAINT_PROPER("chdir");
6ad3d225 2937 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW
2938#ifdef VMS
2939 /* Clear the DEFAULT element of ENV so we'll get the new value
2940 * in the future. */
6b88bc9c 2941 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 2942#endif
a0d0e21e
LW
2943 RETURN;
2944}
2945
2946PP(pp_chown)
2947{
4e35701f 2948 djSP; dMARK; dTARGET;
a0d0e21e
LW
2949 I32 value;
2950#ifdef HAS_CHOWN
533c011a 2951 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2952 SP = MARK;
2953 PUSHi(value);
2954 RETURN;
2955#else
22c35a8c 2956 DIE(PL_no_func, "Unsupported function chown");
a0d0e21e
LW
2957#endif
2958}
2959
2960PP(pp_chroot)
2961{
4e35701f 2962 djSP; dTARGET;
a0d0e21e
LW
2963 char *tmps;
2964#ifdef HAS_CHROOT
2d8e6c8d
GS
2965 STRLEN n_a;
2966 tmps = POPpx;
a0d0e21e
LW
2967 TAINT_PROPER("chroot");
2968 PUSHi( chroot(tmps) >= 0 );
2969 RETURN;
2970#else
22c35a8c 2971 DIE(PL_no_func, "chroot");
a0d0e21e
LW
2972#endif
2973}
2974
2975PP(pp_unlink)
2976{
4e35701f 2977 djSP; dMARK; dTARGET;
a0d0e21e 2978 I32 value;
533c011a 2979 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2980 SP = MARK;
2981 PUSHi(value);
2982 RETURN;
2983}
2984
2985PP(pp_chmod)
2986{
4e35701f 2987 djSP; dMARK; dTARGET;
a0d0e21e 2988 I32 value;
533c011a 2989 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
2990 SP = MARK;
2991 PUSHi(value);
2992 RETURN;
2993}
2994
2995PP(pp_utime)
2996{
4e35701f 2997 djSP; dMARK; dTARGET;
a0d0e21e 2998 I32 value;
533c011a 2999 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3000 SP = MARK;
3001 PUSHi(value);
3002 RETURN;
3003}
3004
3005PP(pp_rename)
3006{
4e35701f 3007 djSP; dTARGET;
a0d0e21e 3008 int anum;
2d8e6c8d 3009 STRLEN n_a;
a0d0e21e 3010
2d8e6c8d
GS
3011 char *tmps2 = POPpx;
3012 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3013 TAINT_PROPER("rename");
3014#ifdef HAS_RENAME
baed7233 3015 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3016#else
6b88bc9c 3017 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
WK
3018 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3019 anum = 1;
3020 else {
3654eb6c 3021 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
WK
3022 (void)UNLINK(tmps2);
3023 if (!(anum = link(tmps, tmps2)))
3024 anum = UNLINK(tmps);
3025 }
a0d0e21e
LW
3026 }
3027#endif
3028 SETi( anum >= 0 );
3029 RETURN;
3030}
3031
3032PP(pp_link)
3033{
4e35701f 3034 djSP; dTARGET;
a0d0e21e 3035#ifdef HAS_LINK
2d8e6c8d
GS
3036 STRLEN n_a;
3037 char *tmps2 = POPpx;
3038 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3039 TAINT_PROPER("link");
3040 SETi( link(tmps, tmps2) >= 0 );
3041#else
22c35a8c 3042 DIE(PL_no_func, "Unsupported function link");
a0d0e21e
LW
3043#endif
3044 RETURN;
3045}
3046
3047PP(pp_symlink)
3048{
4e35701f 3049 djSP; dTARGET;
a0d0e21e 3050#ifdef HAS_SYMLINK
2d8e6c8d
GS
3051 STRLEN n_a;
3052 char *tmps2 = POPpx;
3053 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3054 TAINT_PROPER("symlink");
3055 SETi( symlink(tmps, tmps2) >= 0 );
3056 RETURN;
3057#else
22c35a8c 3058 DIE(PL_no_func, "symlink");
a0d0e21e
LW
3059#endif
3060}
3061
3062PP(pp_readlink)
3063{
4e35701f 3064 djSP; dTARGET;
a0d0e21e
LW
3065#ifdef HAS_SYMLINK
3066 char *tmps;
46fc3d4c 3067 char buf[MAXPATHLEN];
a0d0e21e 3068 int len;
2d8e6c8d 3069 STRLEN n_a;
46fc3d4c 3070
fb73857a
PP
3071#ifndef INCOMPLETE_TAINTS
3072 TAINT;
3073#endif
2d8e6c8d 3074 tmps = POPpx;
a0d0e21e
LW
3075 len = readlink(tmps, buf, sizeof buf);
3076 EXTEND(SP, 1);
3077 if (len < 0)
3078 RETPUSHUNDEF;
3079 PUSHp(buf, len);
3080 RETURN;
3081#else
3082 EXTEND(SP, 1);
3083 RETSETUNDEF; /* just pretend it's a normal file */
3084#endif
3085}
3086
3087#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3088static int
3089dooneliner(cmd, filename)
3090char *cmd;
3091char *filename;
3092{
1e422769
PP
3093 char *save_filename = filename;
3094 char *cmdline;
3095 char *s;
760ac839 3096 PerlIO *myfp;
1e422769 3097 int anum = 1;
a0d0e21e 3098
1e422769
PP
3099 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3100 strcpy(cmdline, cmd);
3101 strcat(cmdline, " ");
3102 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW
3103 *s++ = '\\';
3104 *s++ = *filename++;
3105 }
3106 strcpy(s, " 2>&1");
6ad3d225 3107 myfp = PerlProc_popen(cmdline, "r");
1e422769
PP
3108 Safefree(cmdline);
3109
a0d0e21e 3110 if (myfp) {
1e422769 3111 SV *tmpsv = sv_newmortal();
6b88bc9c 3112 /* Need to save/restore 'PL_rs' ?? */
760ac839 3113 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3114 (void)PerlProc_pclose(myfp);
a0d0e21e 3115 if (s != Nullch) {
1e422769
PP
3116 int e;
3117 for (e = 1;
a0d0e21e 3118#ifdef HAS_SYS_ERRLIST
1e422769
PP
3119 e <= sys_nerr
3120#endif
3121 ; e++)
3122 {
3123 /* you don't see this */
3124 char *errmsg =
3125#ifdef HAS_SYS_ERRLIST
3126 sys_errlist[e]
a0d0e21e 3127#else
1e422769 3128 strerror(e)
a0d0e21e 3129#endif
1e422769
PP
3130 ;
3131 if (!errmsg)
3132 break;
3133 if (instr(s, errmsg)) {
3134 SETERRNO(e,0);
3135 return 0;
3136 }
a0d0e21e 3137 }
748a9306 3138 SETERRNO(0,0);
a0d0e21e
LW
3139#ifndef EACCES
3140#define EACCES EPERM
3141#endif
1e422769 3142 if (instr(s, "cannot make"))
748a9306 3143 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3144 else if (instr(s, "existing file"))
748a9306 3145 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3146 else if (instr(s, "ile exists"))
748a9306 3147 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3148 else if (instr(s, "non-exist"))
748a9306 3149 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3150 else if (instr(s, "does not exist"))
748a9306 3151 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3152 else if (instr(s, "not empty"))
748a9306 3153 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3154 else if (instr(s, "cannot access"))
748a9306 3155 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3156 else
748a9306 3157 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW
3158 return 0;
3159 }
3160 else { /* some mkdirs return no failure indication */
6b88bc9c 3161 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3162 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW
3163 anum = !anum;
3164 if (anum)
748a9306 3165 SETERRNO(0,0);
a0d0e21e 3166 else
748a9306 3167 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW
3168 }
3169 return anum;
3170 }
3171 else
3172 return 0;
3173}
3174#endif
3175
3176PP(pp_mkdir)
3177{
4e35701f 3178 djSP; dTARGET;
a0d0e21e
LW
3179 int mode = POPi;
3180#ifndef HAS_MKDIR
3181 int oldumask;
3182#endif
2d8e6c8d
GS
3183 STRLEN n_a;
3184 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW
3185
3186 TAINT_PROPER("mkdir");
3187#ifdef HAS_MKDIR
6ad3d225 3188 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW
3189#else
3190 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS
3191 oldumask = PerlLIO_umask(0);
3192 PerlLIO_umask(oldumask);
3193 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW
3194#endif
3195 RETURN;
3196}
3197
3198PP(pp_rmdir)
3199{
4e35701f 3200 djSP; dTARGET;
a0d0e21e 3201 char *tmps;
2d8e6c8d 3202 STRLEN n_a;
a0d0e21e 3203
2d8e6c8d 3204 tmps = POPpx;
a0d0e21e
LW
3205 TAINT_PROPER("rmdir");
3206#ifdef HAS_RMDIR
6ad3d225 3207 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW
3208#else
3209 XPUSHi( dooneliner("rmdir", tmps) );
3210#endif
3211 RETURN;
3212}
3213
3214/* Directory calls. */
3215
3216PP(pp_open_dir)
3217{
4e35701f 3218 djSP;
a0d0e21e 3219#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS
3220 STRLEN n_a;
3221 char *dirname = POPpx;
a0d0e21e
LW
3222 GV *gv = (GV*)POPs;
3223 register IO *io = GvIOn(gv);
3224
3225 if (!io)
3226 goto nope;
3227
3228 if (IoDIRP(io))
6ad3d225
GS
3229 PerlDir_close(IoDIRP(io));
3230 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW
3231 goto nope;
3232
3233 RETPUSHYES;
3234nope:
3235 if (!errno)
748a9306 3236 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW
3237 RETPUSHUNDEF;
3238#else
22c35a8c 3239 DIE(PL_no_dir_func, "opendir");
a0d0e21e
LW
3240#endif
3241}
3242
3243PP(pp_readdir)
3244{
4e35701f 3245 djSP;
a0d0e21e
LW
3246#if defined(Direntry_t) && defined(HAS_READDIR)
3247#ifndef I_DIRENT
3248 Direntry_t *readdir _((DIR *));
3249#endif
3250 register Direntry_t *dp;
3251 GV *gv = (GV*)POPs;
3252 register IO *io = GvIOn(gv);
fb73857a 3253 SV *sv;
a0d0e21e
LW
3254
3255 if (!io || !IoDIRP(io))
3256 goto nope;
3257
3258 if (GIMME == G_ARRAY) {
3259 /*SUPPRESS 560*/
6ad3d225 3260 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3261#ifdef DIRNAMLEN
79cb57f6 3262 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3263#else
fb73857a
PP
3264 sv = newSVpv(dp->d_name, 0);
3265#endif
3266#ifndef INCOMPLETE_TAINTS
3267 SvTAINTED_on(sv);
a0d0e21e 3268#endif
fb73857a 3269 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
3270 }
3271 }
3272 else {
6ad3d225 3273 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW
3274 goto nope;
3275#ifdef DIRNAMLEN
79cb57f6 3276 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3277#else
fb73857a 3278 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3279#endif
fb73857a
PP
3280#ifndef INCOMPLETE_TAINTS
3281 SvTAINTED_on(sv);
3282#endif
3283 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW
3284 }
3285 RETURN;
3286
3287nope:
3288 if (!errno)
748a9306 3289 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3290 if (GIMME == G_ARRAY)
3291 RETURN;
3292 else
3293 RETPUSHUNDEF;
3294#else
22c35a8c 3295 DIE(PL_no_dir_func, "readdir");
a0d0e21e
LW
3296#endif
3297}
3298
3299PP(pp_telldir)
3300{
4e35701f 3301 djSP; dTARGET;
a0d0e21e 3302#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH
3303 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3304 /* XXX netbsd still seemed to.
3305 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3306 --JHI 1999-Feb-02 */
3307# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
a0d0e21e 3308 long telldir _((DIR *));
dfe9444c 3309# endif
a0d0e21e
LW
3310 GV *gv = (GV*)POPs;
3311 register IO *io = GvIOn(gv);
3312
3313 if (!io || !IoDIRP(io))
3314 goto nope;
3315
6ad3d225 3316 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW
3317 RETURN;
3318nope:
3319 if (!errno)
748a9306 3320 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3321 RETPUSHUNDEF;
3322#else
22c35a8c 3323 DIE(PL_no_dir_func, "telldir");
a0d0e21e
LW
3324#endif
3325}
3326
3327PP(pp_seekdir)
3328{
4e35701f 3329 djSP;
a0d0e21e
LW
3330#if defined(HAS_SEEKDIR) || defined(seekdir)
3331 long along = POPl;
3332 GV *gv = (GV*)POPs;
3333 register IO *io = GvIOn(gv);
3334
3335 if (!io || !IoDIRP(io))
3336 goto nope;
3337
6ad3d225 3338 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW
3339
3340 RETPUSHYES;
3341nope:
3342 if (!errno)
748a9306 3343 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3344 RETPUSHUNDEF;
3345#else
22c35a8c 3346 DIE(PL_no_dir_func, "seekdir");
a0d0e21e
LW
3347#endif
3348}
3349
3350PP(pp_rewinddir)
3351{
4e35701f 3352 djSP;
a0d0e21e
LW
3353#if defined(HAS_REWINDDIR) || defined(rewinddir)
3354 GV *gv = (GV*)POPs;
3355 register IO *io = GvIOn(gv);
3356
3357 if (!io || !IoDIRP(io))
3358 goto nope;
3359
6ad3d225 3360 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW
3361 RETPUSHYES;
3362nope:
3363 if (!errno)
748a9306 3364 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW
3365 RETPUSHUNDEF;
3366#else
22c35a8c 3367 DIE(PL_no_dir_func, "rewinddir");
a0d0e21e
LW
3368#endif
3369}
3370
3371PP(pp_closedir)
3372{
4e35701f 3373 djSP;
a0d0e21e
LW
3374#if defined(Direntry_t) && defined(HAS_READDIR)
3375 GV *gv = (GV*)POPs;
3376 register IO *io = GvIOn(gv);
3377
3378 if (!io || !IoDIRP(io))
3379 goto nope;
3380
3381#ifdef VOID_CLOSEDIR
6ad3d225 3382 PerlDir_close(IoDIRP(io));
a0d0e21e 3383#else
6ad3d225 3384 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3385 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3386 goto nope;
748a9306 3387 }
a0d0e21e
LW
3388#endif
3389 IoDIRP(io) = 0;
3390
3391 RETPUSHYES;
3392nope:
3393 if (!errno)
748a9306 3394 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW
3395 RETPUSHUNDEF;
3396#else
22c35a8c 3397 DIE(PL_no_dir_func, "closedir");
a0d0e21e
LW
3398#endif
3399}
3400
3401/* Process control. */
3402
3403PP(pp_fork)
3404{
44a8e56a 3405#ifdef HAS_FORK
4e35701f 3406 djSP; dTARGET;
761237fe 3407 Pid_t childpid;
a0d0e21e
LW
3408 GV *tmpgv;
3409
3410 EXTEND(SP, 1);
a0d0e21e
LW
3411 childpid = fork();
3412 if (childpid < 0)
3413 RETSETUNDEF;
3414 if (!childpid) {
3415 /*SUPPRESS 560*/
3416 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3417 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3418 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW
3419 }
3420 PUSHi(childpid);
3421 RETURN;
3422#else
22c35a8c 3423 DIE(PL_no_func, "Unsupported function fork");
a0d0e21e
LW
3424#endif
3425}
3426
3427PP(pp_wait)
3428{
2d7a9237 3429#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3430 djSP; dTARGET;
761237fe 3431 Pid_t childpid;
a0d0e21e 3432 int argflags;
a0d0e21e 3433
44a8e56a 3434 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3435 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3436 XPUSHi(childpid);
a0d0e21e
LW
3437 RETURN;
3438#else
22c35a8c 3439 DIE(PL_no_func, "Unsupported function wait");
a0d0e21e
LW
3440#endif
3441}
3442
3443PP(pp_waitpid)
3444{
2d7a9237 3445#if !defined(DOSISH) || defined(OS2) || defined(WIN32)
4e35701f 3446 djSP; dTARGET;
761237fe 3447 Pid_t childpid;
a0d0e21e
LW
3448 int optype;
3449 int argflags;
a0d0e21e 3450
a0d0e21e
LW
3451 optype = POPi;
3452 childpid = TOPi;
3453 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3454 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3455 SETi(childpid);
a0d0e21e
LW
3456 RETURN;
3457#else
22c35a8c 3458 DIE(PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW
3459#endif
3460}
3461
3462PP(pp_system)
3463{
4e35701f 3464 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3465 I32 value;
761237fe 3466 Pid_t childpid;
a0d0e21e
LW
3467 int result;
3468 int status;
ff68c719 3469 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3470 STRLEN n_a;
a0d0e21e 3471
a0d0e21e 3472 if (SP - MARK == 1) {
3280af22 3473 if (PL_tainting) {
2d8e6c8d 3474 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW
3475 TAINT_ENV();
3476 TAINT_PROPER("system");
3477 }
3478 }
1e422769 3479#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW
3480 while ((childpid = vfork()) == -1) {
3481 if (errno != EAGAIN) {
3482 value = -1;
3483 SP = ORIGMARK;
3484 PUSHi(value);
3485 RETURN;
3486 }
3487 sleep(5);
3488 }
3489 if (childpid > 0) {
ff68c719
PP
3490 rsignal_save(SIGINT, SIG_IGN, &ihand);
3491 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW
3492 do {
3493 result = wait4pid(childpid, &status, 0);
3494 } while (result == -1 && errno == EINTR);
ff68c719
PP
3495 (void)rsignal_restore(SIGINT, &ihand);
3496 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3497 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW
3498 do_execfree(); /* free any memory child malloced on vfork */
3499 SP = ORIGMARK;
ff0cee69 3500 PUSHi(STATUS_CURRENT);
a0d0e21e
LW
3501 RETURN;
3502 }
533c011a 3503 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW
3504 SV *really = *++MARK;
3505 value = (I32)do_aexec(really, MARK, SP);
3506 }
3507 else if (SP - MARK != 1)
3508 value = (I32)do_aexec(Nullsv, MARK, SP);
3509 else {
2d8e6c8d 3510 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3511 }
6ad3d225 3512 PerlProc__exit(-1);
c3293030 3513#else /* ! FORK or VMS or OS/2 */
911d147d 3514 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3515 SV *really = *++MARK;
4e35701f 3516 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW
3517 }
3518 else if (SP - MARK != 1)
4e35701f 3519 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3520 else {
2d8e6c8d 3521 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3522 }
f86702cc 3523 STATUS_NATIVE_SET(value);
a0d0e21e
LW
3524 do_execfree();
3525 SP = ORIGMARK;
ff0cee69 3526 PUSHi(STATUS_CURRENT);
a0d0e21e
LW
3527#endif /* !FORK or VMS */
3528 RETURN;
3529}
3530
3531PP(pp_exec)
3532{
4e35701f 3533 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3534 I32 value;
2d8e6c8d 3535 STRLEN n_a;
a0d0e21e 3536
533c011a 3537 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW
3538 SV *really = *++MARK;
3539 value = (I32)do_aexec(really, MARK, SP);
3540 }
3541 else if (SP - MARK != 1)
3542#ifdef VMS
3543 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3544#else
092bebab
JH
3545# ifdef __OPEN_VM
3546 {
3547 (void ) do_aspawn(Nullsv, MARK, SP);
3548 value = 0;
3549 }
3550# else
a0d0e21e 3551 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3552# endif
a0d0e21e
LW
3553#endif
3554 else {
3280af22 3555 if (PL_tainting) {
2d8e6c8d 3556 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW
3557 TAINT_ENV();
3558 TAINT_PROPER("exec");
3559 }
3560#ifdef VMS
2d8e6c8d 3561 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3562#else
092bebab 3563# ifdef __OPEN_VM
2d8e6c8d 3564 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH
3565 value = 0;
3566# else
2d8e6c8d 3567 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3568# endif
a0d0e21e
LW
3569#endif
3570 }
3571 SP = ORIGMARK;
3572 PUSHi(value);
3573 RETURN;
3574}
3575
3576PP(pp_kill)
3577{
4e35701f 3578 djSP; dMARK; dTARGET;
a0d0e21e
LW
3579 I32 value;
3580#ifdef HAS_KILL
533c011a 3581 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW
3582 SP = MARK;
3583 PUSHi(value);
3584 RETURN;
3585#else
22c35a8c 3586 DIE(PL_no_func, "Unsupported function kill");
a0d0e21e
LW
3587#endif
3588}
3589
3590PP(pp_getppid)
3591{
3592#ifdef HAS_GETPPID
4e35701f 3593 djSP; dTARGET;
a0d0e21e
LW
3594 XPUSHi( getppid() );
3595 RETURN;
3596#else
22c35a8c 3597 DIE(PL_no_func, "getppid");
a0d0e21e
LW
3598#endif
3599}
3600
3601PP(pp_getpgrp)
3602{
3603#ifdef HAS_GETPGRP
4e35701f 3604 djSP; dTARGET;
a0d0e21e
LW
3605 int pid;
3606 I32 value;
3607
3608 if (MAXARG < 1)
3609 pid = 0;
3610 else
3611 pid = SvIVx(POPs);
c3293030
IZ
3612#ifdef BSD_GETPGRP
3613 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3614#else
aa689395 3615 if (pid != 0 && pid != getpid())
a0d0e21e
LW
3616 DIE("POSIX getpgrp can't take an argument");
3617 value = (I32)getpgrp();
3618#endif
3619 XPUSHi(value);
3620 RETURN;
3621#else
22c35a8c 3622 DIE(PL_no_func, "getpgrp()");
a0d0e21e
LW
3623#endif
3624}
3625
3626PP(pp_setpgrp)
3627{
3628#ifdef HAS_SETPGRP
4e35701f 3629 djSP; dTARGET;
a0d0e21e
LW
3630 int pgrp;
3631 int pid;
3632 if (MAXARG < 2) {
3633 pgrp = 0;
3634 pid = 0;
3635 }
3636 else {
3637 pgrp = POPi;
3638 pid = TOPi;
3639 }
3640
3641 TAINT_PROPER("setpgrp");
c3293030
IZ
3642#ifdef BSD_SETPGRP
3643 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3644#else
c90c0ff4 3645 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3646 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW
3647 SETi( setpgrp() >= 0 );
3648#endif /* USE_BSDPGRP */
3649 RETURN;
3650#else
22c35a8c