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