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