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