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