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