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