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