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