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