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