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