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