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