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