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