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