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