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