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