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