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