This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
pp_return(): tail call pp_leaveeval()
[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;
a0d0e21e 1440
8b8cacda 1441 if (!io || !(ofp = IoOFP(io)))
1442 goto forget_top;
1443
760ac839 1444 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1445 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
8b8cacda 1446
3280af22
NIS
1447 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1448 PL_formtarget != PL_toptarget)
a0d0e21e 1449 {
4633a7c4
LW
1450 GV *fgv;
1451 CV *cv;
a0d0e21e
LW
1452 if (!IoTOP_GV(io)) {
1453 GV *topgv;
a0d0e21e
LW
1454
1455 if (!IoTOP_NAME(io)) {
1b6737cc 1456 SV *topname;
a0d0e21e
LW
1457 if (!IoFMT_NAME(io))
1458 IoFMT_NAME(io) = savepv(GvNAME(gv));
d0c0e7dd
FC
1459 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1460 HEKfARG(GvNAME_HEK(gv))));
f776e3cd 1461 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
748a9306 1462 if ((topgv && GvFORM(topgv)) ||
fafc274c 1463 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
2e0de35c 1464 IoTOP_NAME(io) = savesvpv(topname);
a0d0e21e 1465 else
89529cee 1466 IoTOP_NAME(io) = savepvs("top");
a0d0e21e 1467 }
f776e3cd 1468 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
a0d0e21e 1469 if (!topgv || !GvFORM(topgv)) {
b929a54b 1470 IoLINES_LEFT(io) = IoPAGE_LEN(io);
a0d0e21e
LW
1471 goto forget_top;
1472 }
1473 IoTOP_GV(io) = topgv;
1474 }
748a9306
LW
1475 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1476 I32 lines = IoLINES_LEFT(io);
504618e9 1477 const char *s = SvPVX_const(PL_formtarget);
8e07c86e
AD
1478 if (lines <= 0) /* Yow, header didn't even fit!!! */
1479 goto forget_top;
748a9306
LW
1480 while (lines-- > 0) {
1481 s = strchr(s, '\n');
1482 if (!s)
1483 break;
1484 s++;
1485 }
1486 if (s) {
f54cb97a 1487 const STRLEN save = SvCUR(PL_formtarget);
aa07b2f6 1488 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
d75029d0
NIS
1489 do_print(PL_formtarget, ofp);
1490 SvCUR_set(PL_formtarget, save);
3280af22
NIS
1491 sv_chop(PL_formtarget, s);
1492 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1493 }
1494 }
a0d0e21e 1495 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
f6dfc736 1496 do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
a0d0e21e
LW
1497 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1498 IoPAGE(io)++;
3280af22 1499 PL_formtarget = PL_toptarget;
748a9306 1500 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4 1501 fgv = IoTOP_GV(io);
636013b3 1502 assert(fgv); /* IoTOP_GV(io) should have been set above */
4633a7c4 1503 cv = GvFORM(fgv);
1df70142
AL
1504 if (!cv) {
1505 SV * const sv = sv_newmortal();
bd61b366 1506 gv_efullname4(sv, fgv, NULL, FALSE);
44b7e78a 1507 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
4633a7c4 1508 }
43cd5cb7 1509 return doform(cv, gv, PL_op);
a0d0e21e
LW
1510 }
1511
1512 forget_top:
3280af22 1513 POPBLOCK(cx,PL_curpm);
8f89e5a9 1514 retop = cx->blk_sub.retop;
25375124 1515 POPFORMAT(cx);
43cd5cb7 1516 SP = newsp; /* ignore retval of formline */
a0d0e21e
LW
1517 LEAVE;
1518
c782dc1d
FC
1519 if (!io || !(fp = IoOFP(io))) {
1520 if (io && IoIFP(io))
7716c5c5 1521 report_wrongway_fh(gv, '<');
c521cf7c 1522 else
7716c5c5 1523 report_evil_fh(gv);
3280af22 1524 PUSHs(&PL_sv_no);
a0d0e21e
LW
1525 }
1526 else {
3280af22 1527 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
a2a5de95 1528 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
a0d0e21e 1529 }
d75029d0 1530 if (!do_print(PL_formtarget, fp))
3280af22 1531 PUSHs(&PL_sv_no);
a0d0e21e 1532 else {
3280af22
NIS
1533 FmLINES(PL_formtarget) = 0;
1534 SvCUR_set(PL_formtarget, 0);
1535 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1536 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1537 (void)PerlIO_flush(fp);
3280af22 1538 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1539 }
1540 }
3280af22 1541 PL_formtarget = PL_bodytarget;
29033a8a 1542 PERL_UNUSED_VAR(gimme);
8e4ecf23 1543 RETURNOP(retop);
a0d0e21e
LW
1544}
1545
1546PP(pp_prtf)
1547{
20b7effb 1548 dSP; dMARK; dORIGMARK;
760ac839 1549 PerlIO *fp;
a0d0e21e 1550
159b6efe
NC
1551 GV * const gv
1552 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1553 IO *const io = GvIO(gv);
46fc3d4c 1554
87385d72
FC
1555 /* Treat empty list as "" */
1556 if (MARK == SP) XPUSHs(&PL_sv_no);
1557
9c9f25b8 1558 if (io) {
a5e1d062 1559 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d
AL
1560 if (mg) {
1561 if (MARK == ORIGMARK) {
1562 MEXTEND(SP, 1);
1563 ++MARK;
1564 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1565 ++SP;
1566 }
3e0cb5de 1567 return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
d682515d
NC
1568 mg,
1569 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1570 sp - mark);
a79db61d 1571 }
46fc3d4c
PP
1572 }
1573
9c9f25b8 1574 if (!io) {
51087808 1575 report_evil_fh(gv);
93189314 1576 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
1577 goto just_say_no;
1578 }
1579 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
1580 if (IoIFP(io))
1581 report_wrongway_fh(gv, '<');
1582 else if (ckWARN(WARN_CLOSED))
1583 report_evil_fh(gv);
93189314 1584 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
1585 goto just_say_no;
1586 }
1587 else {
c7bd8b84 1588 SV *sv = sv_newmortal();
a0d0e21e
LW
1589 do_sprintf(sv, SP - MARK, MARK + 1);
1590 if (!do_print(sv, fp))
1591 goto just_say_no;
1592
1593 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1594 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1595 goto just_say_no;
1596 }
a0d0e21e 1597 SP = ORIGMARK;
3280af22 1598 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1599 RETURN;
1600
1601 just_say_no:
a0d0e21e 1602 SP = ORIGMARK;
3280af22 1603 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1604 RETURN;
1605}
1606
c07a80fd
PP
1607PP(pp_sysopen)
1608{
39644a26 1609 dSP;
de5e49e1 1610 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1df70142 1611 const int mode = POPi;
1b6737cc 1612 SV * const sv = POPs;
159b6efe 1613 GV * const gv = MUTABLE_GV(POPs);
1b6737cc 1614 STRLEN len;
c07a80fd 1615
4592e6ca 1616 /* Need TIEHANDLE method ? */
1b6737cc 1617 const char * const tmps = SvPV_const(sv, len);
d5eb9a46 1618 if (do_open_raw(gv, tmps, len, mode, perm)) {
c07a80fd 1619 IoLINES(GvIOp(gv)) = 0;
3280af22 1620 PUSHs(&PL_sv_yes);
c07a80fd
PP
1621 }
1622 else {
3280af22 1623 PUSHs(&PL_sv_undef);
c07a80fd
PP
1624 }
1625 RETURN;
1626}
1627
b1c05ba5
DM
1628
1629/* also used for: pp_read() and pp_recv() (where supported) */
1630
a0d0e21e
LW
1631PP(pp_sysread)
1632{
20b7effb 1633 dSP; dMARK; dORIGMARK; dTARGET;
0b423688 1634 SSize_t offset;
a0d0e21e
LW
1635 IO *io;
1636 char *buffer;
0b423688 1637 STRLEN orig_size;
5b54f415 1638 SSize_t length;
eb5c063a 1639 SSize_t count;
748a9306 1640 SV *bufsv;
a0d0e21e 1641 STRLEN blen;
eb5c063a 1642 int fp_utf8;
1dd30107
NC
1643 int buffer_utf8;
1644 SV *read_target;
eb5c063a
NIS
1645 Size_t got = 0;
1646 Size_t wanted;
1d636c13 1647 bool charstart = FALSE;
87330c3c
JH
1648 STRLEN charskip = 0;
1649 STRLEN skip = 0;
159b6efe 1650 GV * const gv = MUTABLE_GV(*++MARK);
375ed12a
JH
1651 int fd;
1652
5b468f54 1653 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1b6737cc 1654 && gv && (io = GvIO(gv)) )
137443ea 1655 {
a5e1d062 1656 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1b6737cc 1657 if (mg) {
3e0cb5de 1658 return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
d682515d
NC
1659 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1660 sp - mark);
1b6737cc 1661 }
2ae324a7
PP
1662 }
1663
a0d0e21e
LW
1664 if (!gv)
1665 goto say_undef;
748a9306 1666 bufsv = *++MARK;
ff68c719 1667 if (! SvOK(bufsv))
76f68e9b 1668 sv_setpvs(bufsv, "");
a0d0e21e 1669 length = SvIVx(*++MARK);
4bac9ae4
CS
1670 if (length < 0)
1671 DIE(aTHX_ "Negative length");
748a9306 1672 SETERRNO(0,0);
a0d0e21e
LW
1673 if (MARK < SP)
1674 offset = SvIVx(*++MARK);
1675 else
1676 offset = 0;
1677 io = GvIO(gv);
b5fe5ca2 1678 if (!io || !IoIFP(io)) {
51087808 1679 report_evil_fh(gv);
b5fe5ca2 1680 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1681 goto say_undef;
b5fe5ca2 1682 }
375ed12a
JH
1683
1684 /* Note that fd can here validly be -1, don't check it yet. */
1685 fd = PerlIO_fileno(IoIFP(io));
1686
0064a8a9 1687 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
7d59b7e4 1688 buffer = SvPVutf8_force(bufsv, blen);
1e54db1a 1689 /* UTF-8 may not have been set if they are all low bytes */
eb5c063a 1690 SvUTF8_on(bufsv);
9b9d7ce8 1691 buffer_utf8 = 0;
7d59b7e4
NIS
1692 }
1693 else {
1694 buffer = SvPV_force(bufsv, blen);
1dd30107 1695 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
7d59b7e4 1696 }
4bac9ae4 1697 if (DO_UTF8(bufsv)) {
3f914778 1698 blen = sv_len_utf8_nomg(bufsv);
4bac9ae4 1699 }
7d59b7e4 1700
d0965105
JH
1701 charstart = TRUE;
1702 charskip = 0;
87330c3c 1703 skip = 0;
4bac9ae4 1704 wanted = length;
d0965105 1705
a0d0e21e 1706#ifdef HAS_SOCKET
533c011a 1707 if (PL_op->op_type == OP_RECV) {
0b423688 1708 Sock_size_t bufsize;
46fc3d4c 1709 char namebuf[MAXPATHLEN];
375ed12a
JH
1710 if (fd < 0) {
1711 SETERRNO(EBADF,SS_IVCHAN);
1712 RETPUSHUNDEF;
1713 }
b5afd346 1714#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
490ab354
JH
1715 bufsize = sizeof (struct sockaddr_in);
1716#else
46fc3d4c 1717 bufsize = sizeof namebuf;
490ab354 1718#endif
abf95952
IZ
1719#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1720 if (bufsize >= 256)
1721 bufsize = 255;
1722#endif
eb160463 1723 buffer = SvGROW(bufsv, (STRLEN)(length+1));
bbce6d69 1724 /* 'offset' means 'flags' here */
375ed12a 1725 count = PerlSock_recvfrom(fd, buffer, length, offset,
10edeb5d 1726 (struct sockaddr *)namebuf, &bufsize);
eb5c063a 1727 if (count < 0)
a0d0e21e 1728 RETPUSHUNDEF;
8eb023a9
DM
1729 /* MSG_TRUNC can give oversized count; quietly lose it */
1730 if (count > length)
1731 count = length;
eb5c063a 1732 SvCUR_set(bufsv, count);
748a9306
LW
1733 *SvEND(bufsv) = '\0';
1734 (void)SvPOK_only(bufsv);
eb5c063a
NIS
1735 if (fp_utf8)
1736 SvUTF8_on(bufsv);
748a9306 1737 SvSETMAGIC(bufsv);
aac0dd9a 1738 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1739 if (!(IoFLAGS(io) & IOf_UNTAINT))
1740 SvTAINTED_on(bufsv);
a0d0e21e 1741 SP = ORIGMARK;
e122534c
TC
1742#if defined(__CYGWIN__)
1743 /* recvfrom() on cygwin doesn't set bufsize at all for
1744 connected sockets, leaving us with trash in the returned
1745 name, so use the same test as the Win32 code to check if it
1746 wasn't set, and set it [perl #118843] */
1747 if (bufsize == sizeof namebuf)
1748 bufsize = 0;
1749#endif
46fc3d4c 1750 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1751 PUSHs(TARG);
1752 RETURN;
1753 }
a0d0e21e 1754#endif
bbce6d69 1755 if (offset < 0) {
0b423688 1756 if (-offset > (SSize_t)blen)
cea2e8a9 1757 DIE(aTHX_ "Offset outside string");
bbce6d69
PP
1758 offset += blen;
1759 }
eb5c063a
NIS
1760 if (DO_UTF8(bufsv)) {
1761 /* convert offset-as-chars to offset-as-bytes */
d5f981bb 1762 if (offset >= (SSize_t)blen)
6960c29a
CH
1763 offset += SvCUR(bufsv) - blen;
1764 else
1765 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
eb5c063a 1766 }
375ed12a 1767
eb5c063a 1768 more_bytes:
375ed12a
JH
1769 /* Reestablish the fd in case it shifted from underneath us. */
1770 fd = PerlIO_fileno(IoIFP(io));
1771
0b423688 1772 orig_size = SvCUR(bufsv);
1dd30107
NC
1773 /* Allocating length + offset + 1 isn't perfect in the case of reading
1774 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1775 unduly.
1776 (should be 2 * length + offset + 1, or possibly something longer if
47e13f24 1777 IN_ENCODING Is true) */
eb160463 1778 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
0b423688
TC
1779 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1780 Zero(buffer+orig_size, offset-orig_size, char);
cd52b7b2 1781 }
eb5c063a 1782 buffer = buffer + offset;
1dd30107
NC
1783 if (!buffer_utf8) {
1784 read_target = bufsv;
1785 } else {
1786 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1787 concatenate it to the current buffer. */
1788
1789 /* Truncate the existing buffer to the start of where we will be
1790 reading to: */
1791 SvCUR_set(bufsv, offset);
1792
1793 read_target = sv_newmortal();
862a34c6 1794 SvUPGRADE(read_target, SVt_PV);
fe2774ed 1795 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1dd30107 1796 }
eb5c063a 1797
533c011a 1798 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1799#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1800 if (IoTYPE(io) == IoTYPE_SOCKET) {
375ed12a
JH
1801 if (fd < 0) {
1802 SETERRNO(EBADF,SS_IVCHAN);
1803 count = -1;
1804 }
1805 else
1806 count = PerlSock_recv(fd, buffer, length, 0);
a7092146
GS
1807 }
1808 else
1809#endif
1810 {
375ed12a
JH
1811 if (fd < 0) {
1812 SETERRNO(EBADF,RMS_IFI);
1813 count = -1;
1814 }
1815 else
1816 count = PerlLIO_read(fd, buffer, length);
a7092146 1817 }
a0d0e21e
LW
1818 }
1819 else
3b02c43c 1820 {
eb5c063a
NIS
1821 count = PerlIO_read(IoIFP(io), buffer, length);
1822 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1823 if (count == 0 && PerlIO_error(IoIFP(io)))
1824 count = -1;
3b02c43c 1825 }
eb5c063a 1826 if (count < 0) {
7716c5c5 1827 if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1828 report_wrongway_fh(gv, '>');
a0d0e21e 1829 goto say_undef;
af8c498a 1830 }
aa07b2f6 1831 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1dd30107
NC
1832 *SvEND(read_target) = '\0';
1833 (void)SvPOK_only(read_target);
0064a8a9 1834 if (fp_utf8 && !IN_BYTES) {
eb5c063a 1835 /* Look at utf8 we got back and count the characters */
1df70142 1836 const char *bend = buffer + count;
eb5c063a 1837 while (buffer < bend) {
d0965105
JH
1838 if (charstart) {
1839 skip = UTF8SKIP(buffer);
1840 charskip = 0;
1841 }
1842 if (buffer - charskip + skip > bend) {
eb5c063a
NIS
1843 /* partial character - try for rest of it */
1844 length = skip - (bend-buffer);
aa07b2f6 1845 offset = bend - SvPVX_const(bufsv);
d0965105
JH
1846 charstart = FALSE;
1847 charskip += count;
eb5c063a
NIS
1848 goto more_bytes;
1849 }
1850 else {
1851 got++;
1852 buffer += skip;
d0965105
JH
1853 charstart = TRUE;
1854 charskip = 0;
eb5c063a
NIS
1855 }
1856 }
1857 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1858 provided amount read (count) was what was requested (length)
1859 */
1860 if (got < wanted && count == length) {
d0965105 1861 length = wanted - got;
aa07b2f6 1862 offset = bend - SvPVX_const(bufsv);
eb5c063a
NIS
1863 goto more_bytes;
1864 }
1865 /* return value is character count */
1866 count = got;
1867 SvUTF8_on(bufsv);
1868 }
1dd30107
NC
1869 else if (buffer_utf8) {
1870 /* Let svcatsv upgrade the bytes we read in to utf8.
1871 The buffer is a mortal so will be freed soon. */
1872 sv_catsv_nomg(bufsv, read_target);
1873 }
748a9306 1874 SvSETMAGIC(bufsv);
aac0dd9a 1875 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1876 if (!(IoFLAGS(io) & IOf_UNTAINT))
1877 SvTAINTED_on(bufsv);
a0d0e21e 1878 SP = ORIGMARK;
eb5c063a 1879 PUSHi(count);
a0d0e21e
LW
1880 RETURN;
1881
1882 say_undef:
1883 SP = ORIGMARK;
1884 RETPUSHUNDEF;
1885}
1886
b1c05ba5
DM
1887
1888/* also used for: pp_send() where defined */
1889
60504e18 1890PP(pp_syswrite)
a0d0e21e 1891{
20b7effb 1892 dSP; dMARK; dORIGMARK; dTARGET;
748a9306 1893 SV *bufsv;
83003860 1894 const char *buffer;
8c99d73e 1895 SSize_t retval;
a0d0e21e 1896 STRLEN blen;
c9cb0f41 1897 STRLEN orig_blen_bytes;
64a1bc8e 1898 const int op_type = PL_op->op_type;
c9cb0f41
NC
1899 bool doing_utf8;
1900 U8 *tmpbuf = NULL;
159b6efe 1901 GV *const gv = MUTABLE_GV(*++MARK);
91472ad4 1902 IO *const io = GvIO(gv);
375ed12a 1903 int fd;
91472ad4
NC
1904
1905 if (op_type == OP_SYSWRITE && io) {
a5e1d062 1906 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1907 if (mg) {
a79db61d 1908 if (MARK == SP - 1) {
c8834ab7
TC
1909 SV *sv = *SP;
1910 mXPUSHi(sv_len(sv));
a79db61d
AL
1911 PUTBACK;
1912 }
1913
3e0cb5de 1914 return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
d682515d
NC
1915 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1916 sp - mark);
64a1bc8e 1917 }
1d603a67 1918 }
a0d0e21e
LW
1919 if (!gv)
1920 goto say_undef;
64a1bc8e 1921
748a9306 1922 bufsv = *++MARK;
64a1bc8e 1923
748a9306 1924 SETERRNO(0,0);
cf167416 1925 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
8c99d73e 1926 retval = -1;
51087808
NC
1927 if (io && IoIFP(io))
1928 report_wrongway_fh(gv, '<');
1929 else
1930 report_evil_fh(gv);
b5fe5ca2 1931 SETERRNO(EBADF,RMS_IFI);
7d59b7e4
NIS
1932 goto say_undef;
1933 }
375ed12a
JH
1934 fd = PerlIO_fileno(IoIFP(io));
1935 if (fd < 0) {
1936 SETERRNO(EBADF,SS_IVCHAN);
1937 retval = -1;
1938 goto say_undef;
1939 }
7d59b7e4 1940
c9cb0f41
NC
1941 /* Do this first to trigger any overloading. */
1942 buffer = SvPV_const(bufsv, blen);
1943 orig_blen_bytes = blen;
1944 doing_utf8 = DO_UTF8(bufsv);
1945
7d59b7e4 1946 if (PerlIO_isutf8(IoIFP(io))) {
6aa2f6a7 1947 if (!SvUTF8(bufsv)) {
c9cb0f41
NC
1948 /* We don't modify the original scalar. */
1949 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1950 buffer = (char *) tmpbuf;
1951 doing_utf8 = TRUE;
1952 }
a0d0e21e 1953 }
c9cb0f41
NC
1954 else if (doing_utf8) {
1955 STRLEN tmplen = blen;
a79db61d 1956 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
c9cb0f41
NC
1957 if (!doing_utf8) {
1958 tmpbuf = result;
1959 buffer = (char *) tmpbuf;
1960 blen = tmplen;
1961 }
1962 else {
1963 assert((char *)result == buffer);
1964 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1965 }
7d59b7e4
NIS
1966 }
1967
e2712234 1968#ifdef HAS_SOCKET
7627e6d0 1969 if (op_type == OP_SEND) {
e2712234
NC
1970 const int flags = SvIVx(*++MARK);
1971 if (SP > MARK) {
1972 STRLEN mlen;
1973 char * const sockbuf = SvPVx(*++MARK, mlen);
375ed12a 1974 retval = PerlSock_sendto(fd, buffer, blen,
e2712234
NC
1975 flags, (struct sockaddr *)sockbuf, mlen);
1976 }
1977 else {
375ed12a 1978 retval = PerlSock_send(fd, buffer, blen, flags);
e2712234 1979 }
7627e6d0
NC
1980 }
1981 else
e2712234 1982#endif
7627e6d0 1983 {
c9cb0f41
NC
1984 Size_t length = 0; /* This length is in characters. */
1985 STRLEN blen_chars;
7d59b7e4 1986 IV offset;
c9cb0f41
NC
1987
1988 if (doing_utf8) {
1989 if (tmpbuf) {
1990 /* The SV is bytes, and we've had to upgrade it. */
1991 blen_chars = orig_blen_bytes;
1992 } else {
1993 /* The SV really is UTF-8. */
3f914778
FC
1994 /* Don't call sv_len_utf8 on a magical or overloaded
1995 scalar, as we might get back a different result. */
1996 blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
c9cb0f41
NC
1997 }
1998 } else {
1999 blen_chars = blen;
2000 }
2001
2002 if (MARK >= SP) {
2003 length = blen_chars;
2004 } else {
2005#if Size_t_size > IVSIZE
2006 length = (Size_t)SvNVx(*++MARK);
2007#else
2008 length = (Size_t)SvIVx(*++MARK);
2009#endif
4b0c4b6f
NC
2010 if ((SSize_t)length < 0) {
2011 Safefree(tmpbuf);
c9cb0f41 2012 DIE(aTHX_ "Negative length");
4b0c4b6f 2013 }
7d59b7e4 2014 }
c9cb0f41 2015
bbce6d69 2016 if (MARK < SP) {
a0d0e21e 2017 offset = SvIVx(*++MARK);
bbce6d69 2018 if (offset < 0) {
4b0c4b6f
NC
2019 if (-offset > (IV)blen_chars) {
2020 Safefree(tmpbuf);
cea2e8a9 2021 DIE(aTHX_ "Offset outside string");
4b0c4b6f 2022 }
c9cb0f41 2023 offset += blen_chars;
3c946528 2024 } else if (offset > (IV)blen_chars) {
4b0c4b6f 2025 Safefree(tmpbuf);
cea2e8a9 2026 DIE(aTHX_ "Offset outside string");
4b0c4b6f 2027 }
bbce6d69 2028 } else
a0d0e21e 2029 offset = 0;
c9cb0f41
NC
2030 if (length > blen_chars - offset)
2031 length = blen_chars - offset;
2032 if (doing_utf8) {
2033 /* Here we convert length from characters to bytes. */
2034 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
2035 /* Either we had to convert the SV, or the SV is magical, or
2036 the SV has overloading, in which case we can't or mustn't
2037 or mustn't call it again. */
2038
2039 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
2040 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
2041 } else {
2042 /* It's a real UTF-8 SV, and it's not going to change under
2043 us. Take advantage of any cache. */
2044 I32 start = offset;
2045 I32 len_I32 = length;
2046
2047 /* Convert the start and end character positions to bytes.
2048 Remember that the second argument to sv_pos_u2b is relative
2049 to the first. */
2050 sv_pos_u2b(bufsv, &start, &len_I32);
2051
2052 buffer += start;
2053 length = len_I32;
2054 }
7d59b7e4
NIS
2055 }
2056 else {
2057 buffer = buffer+offset;
2058 }
a7092146 2059#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 2060 if (IoTYPE(io) == IoTYPE_SOCKET) {
375ed12a 2061 retval = PerlSock_send(fd, buffer, length, 0);
a7092146
GS
2062 }
2063 else
2064#endif
2065 {
94e4c244 2066 /* See the note at doio.c:do_print about filesize limits. --jhi */
375ed12a 2067 retval = PerlLIO_write(fd, buffer, length);
a7092146 2068 }
a0d0e21e 2069 }
c9cb0f41 2070
8c99d73e 2071 if (retval < 0)
a0d0e21e
LW
2072 goto say_undef;
2073 SP = ORIGMARK;
c9cb0f41 2074 if (doing_utf8)
f36eea10 2075 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
4b0c4b6f 2076
a79db61d 2077 Safefree(tmpbuf);
8c99d73e
GS
2078#if Size_t_size > IVSIZE
2079 PUSHn(retval);
2080#else
2081 PUSHi(retval);
2082#endif
a0d0e21e
LW
2083 RETURN;
2084
2085 say_undef:
a79db61d 2086 Safefree(tmpbuf);
a0d0e21e
LW
2087 SP = ORIGMARK;
2088 RETPUSHUNDEF;
2089}
2090
a0d0e21e
LW
2091PP(pp_eof)
2092{
20b7effb 2093 dSP;
a0d0e21e 2094 GV *gv;
32e65323 2095 IO *io;
a5e1d062 2096 const MAGIC *mg;
bc0c81ca
NC
2097 /*
2098 * in Perl 5.12 and later, the additional parameter is a bitmask:
2099 * 0 = eof
2100 * 1 = eof(FH)
2101 * 2 = eof() <- ARGV magic
2102 *
2103 * I'll rely on the compiler's trace flow analysis to decide whether to
2104 * actually assign this out here, or punt it into the only block where it is
2105 * used. Doing it out here is DRY on the condition logic.
2106 */
2107 unsigned int which;
a0d0e21e 2108
bc0c81ca 2109 if (MAXARG) {
32e65323 2110 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
bc0c81ca
NC
2111 which = 1;
2112 }
b5f55170
NC
2113 else {
2114 EXTEND(SP, 1);
2115
bc0c81ca 2116 if (PL_op->op_flags & OPf_SPECIAL) {
b5f55170 2117 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
bc0c81ca
NC
2118 which = 2;
2119 }
2120 else {
b5f55170 2121 gv = PL_last_in_gv; /* eof */
bc0c81ca
NC
2122 which = 0;
2123 }
b5f55170 2124 }
32e65323
CS
2125
2126 if (!gv)
2127 RETPUSHNO;
2128
2129 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
3e0cb5de 2130 return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
146174a9 2131 }
4592e6ca 2132
32e65323
CS
2133 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2134 if (io && !IoIFP(io)) {
b9f2b683 2135 if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) {
1037353b 2136 SV ** svp;
32e65323
CS
2137 IoLINES(io) = 0;
2138 IoFLAGS(io) &= ~IOf_START;
d5eb9a46 2139 do_open6(gv, "-", 1, NULL, NULL, 0);
1037353b
DD
2140 svp = &GvSV(gv);
2141 if (*svp) {
2142 SV * sv = *svp;
2143 sv_setpvs(sv, "-");
2144 SvSETMAGIC(sv);
2145 }
32e65323 2146 else
1037353b 2147 *svp = newSVpvs("-");
32e65323 2148 }
157fb5a1 2149 else if (!nextargv(gv, FALSE))
32e65323 2150 RETPUSHYES;
6136c704 2151 }
4592e6ca
NIS
2152 }
2153
32e65323 2154 PUSHs(boolSV(do_eof(gv)));
a0d0e21e
LW
2155 RETURN;
2156}
2157
2158PP(pp_tell)
2159{
20b7effb 2160 dSP; dTARGET;
301e8125 2161 GV *gv;
5b468f54 2162 IO *io;
a0d0e21e 2163
b64a1294 2164 if (MAXARG != 0 && (TOPs || POPs))
159b6efe 2165 PL_last_in_gv = MUTABLE_GV(POPs);
ac3697cd
NC
2166 else
2167 EXTEND(SP, 1);
c4420975 2168 gv = PL_last_in_gv;
4592e6ca 2169
9c9f25b8
NC
2170 io = GvIO(gv);
2171 if (io) {
a5e1d062 2172 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2173 if (mg) {
3e0cb5de 2174 return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
a79db61d 2175 }
4592e6ca 2176 }
f4817f32 2177 else if (!gv) {
f03173f2
RGS
2178 if (!errno)
2179 SETERRNO(EBADF,RMS_IFI);
2180 PUSHi(-1);
2181 RETURN;
2182 }
4592e6ca 2183
146174a9
CB
2184#if LSEEKSIZE > IVSIZE
2185 PUSHn( do_tell(gv) );
2186#else
a0d0e21e 2187 PUSHi( do_tell(gv) );
146174a9 2188#endif
a0d0e21e
LW
2189 RETURN;
2190}
2191
b1c05ba5
DM
2192
2193/* also used for: pp_seek() */
2194
137443ea
PP
2195PP(pp_sysseek)
2196{
20b7effb 2197 dSP;
1df70142 2198 const int whence = POPi;
146174a9 2199#if LSEEKSIZE > IVSIZE
7452cf6a 2200 const Off_t offset = (Off_t)SvNVx(POPs);
146174a9 2201#else
7452cf6a 2202 const Off_t offset = (Off_t)SvIVx(POPs);
146174a9 2203#endif
a0d0e21e 2204
159b6efe 2205 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
9c9f25b8 2206 IO *const io = GvIO(gv);
4592e6ca 2207
9c9f25b8 2208 if (io) {
a5e1d062 2209 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2210 if (mg) {
cb50131a 2211#if LSEEKSIZE > IVSIZE
74f0b550 2212 SV *const offset_sv = newSVnv((NV) offset);
cb50131a 2213#else
74f0b550 2214 SV *const offset_sv = newSViv(offset);
cb50131a 2215#endif
bc0c81ca 2216
3e0cb5de 2217 return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
d682515d 2218 newSViv(whence));
a79db61d 2219 }
4592e6ca
NIS
2220 }
2221
533c011a 2222 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
2223 PUSHs(boolSV(do_seek(gv, offset, whence)));
2224 else {
0bcc34c2 2225 const Off_t sought = do_sysseek(gv, offset, whence);
b448e4fe 2226 if (sought < 0)
146174a9
CB
2227 PUSHs(&PL_sv_undef);
2228 else {
7452cf6a 2229 SV* const sv = sought ?
146174a9 2230#if LSEEKSIZE > IVSIZE
b448e4fe 2231 newSVnv((NV)sought)
146174a9 2232#else
b448e4fe 2233 newSViv(sought)
146174a9
CB
2234#endif
2235 : newSVpvn(zero_but_true, ZBTLEN);
6e449a3a 2236 mPUSHs(sv);
146174a9 2237 }
8903cb82 2238 }
a0d0e21e
LW
2239 RETURN;
2240}
2241
2242PP(pp_truncate)
2243{
39644a26 2244 dSP;
8c99d73e
GS
2245 /* There seems to be no consensus on the length type of truncate()
2246 * and ftruncate(), both off_t and size_t have supporters. In
2247 * general one would think that when using large files, off_t is
2248 * at least as wide as size_t, so using an off_t should be okay. */
2249 /* XXX Configure probe for the length type of *truncate() needed XXX */
0bcc34c2 2250 Off_t len;
a0d0e21e 2251
25342a55 2252#if Off_t_size > IVSIZE
0bcc34c2 2253 len = (Off_t)POPn;
8c99d73e 2254#else
0bcc34c2 2255 len = (Off_t)POPi;
8c99d73e
GS
2256#endif
2257 /* Checking for length < 0 is problematic as the type might or
301e8125 2258 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2259 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2260 SETERRNO(0,0);
d05c1ba0 2261 {
5e0adc2d 2262 SV * const sv = POPs;
d05c1ba0
JH
2263 int result = 1;
2264 GV *tmpgv;
090bf15b
SR
2265 IO *io;
2266
42409c40
FC
2267 if (PL_op->op_flags & OPf_SPECIAL
2268 ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2269 : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
9c9f25b8
NC
2270 io = GvIO(tmpgv);
2271 if (!io)
090bf15b 2272 result = 0;
d05c1ba0 2273 else {
090bf15b 2274 PerlIO *fp;
090bf15b
SR
2275 do_ftruncate_io:
2276 TAINT_PROPER("truncate");
2277 if (!(fp = IoIFP(io))) {
2278 result = 0;
2279 }
2280 else {
375ed12a
JH
2281 int fd = PerlIO_fileno(fp);
2282 if (fd < 0) {
2283 SETERRNO(EBADF,RMS_IFI);
2284 result = 0;
2285 } else {
2286 PerlIO_flush(fp);
cbdc8872 2287#ifdef HAS_TRUNCATE
375ed12a 2288 if (ftruncate(fd, len) < 0)
301e8125 2289#else
375ed12a 2290 if (my_chsize(fd, len) < 0)
cbdc8872 2291#endif
375ed12a
JH
2292 result = 0;
2293 }
090bf15b 2294 }
d05c1ba0 2295 }
cbdc8872 2296 }
5e0adc2d 2297 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2298 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
090bf15b 2299 goto do_ftruncate_io;
5e0adc2d
FC
2300 }
2301 else {
2302 const char * const name = SvPV_nomg_const_nolen(sv);
d05c1ba0 2303 TAINT_PROPER("truncate");
cbdc8872 2304#ifdef HAS_TRUNCATE
d05c1ba0
JH
2305 if (truncate(name, len) < 0)
2306 result = 0;
cbdc8872 2307#else
d05c1ba0 2308 {
d484df69
TC
2309 int mode = O_RDWR;
2310 int tmpfd;
2311
2312#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
2313 mode |= O_LARGEFILE; /* Transparently largefiley. */
2314#endif
2315#ifdef O_BINARY
2316 /* On open(), the Win32 CRT tries to seek around text
2317 * files using 32-bit offsets, which causes the open()
2318 * to fail on large files, so open in binary mode.
2319 */
2320 mode |= O_BINARY;
2321#endif
2322 tmpfd = PerlLIO_open(name, mode);
d05c1ba0 2323
375ed12a 2324 if (tmpfd < 0) {
cbdc8872 2325 result = 0;
375ed12a 2326 } else {
d05c1ba0
JH
2327 if (my_chsize(tmpfd, len) < 0)
2328 result = 0;
2329 PerlLIO_close(tmpfd);
2330 }
cbdc8872 2331 }
a0d0e21e 2332#endif
d05c1ba0 2333 }
a0d0e21e 2334
d05c1ba0
JH
2335 if (result)
2336 RETPUSHYES;
2337 if (!errno)
93189314 2338 SETERRNO(EBADF,RMS_IFI);
d05c1ba0
JH
2339 RETPUSHUNDEF;
2340 }
a0d0e21e
LW
2341}
2342
b1c05ba5
DM
2343
2344/* also used for: pp_fcntl() */
2345
a0d0e21e
LW
2346PP(pp_ioctl)
2347{
20b7effb 2348 dSP; dTARGET;
7452cf6a 2349 SV * const argsv = POPs;
1df70142 2350 const unsigned int func = POPu;
49225470 2351 int optype;
159b6efe 2352 GV * const gv = MUTABLE_GV(POPs);
8a6c0fcb 2353 IO * const io = GvIOn(gv);
a0d0e21e 2354 char *s;
324aa91a 2355 IV retval;
a0d0e21e 2356
8a6c0fcb 2357 if (!IoIFP(io)) {
51087808 2358 report_evil_fh(gv);
93189314 2359 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
a0d0e21e
LW
2360 RETPUSHUNDEF;
2361 }
2362
748a9306 2363 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2364 STRLEN len;
324aa91a 2365 STRLEN need;
748a9306 2366 s = SvPV_force(argsv, len);
324aa91a
HF
2367 need = IOCPARM_LEN(func);
2368 if (len < need) {
2369 s = Sv_Grow(argsv, need + 1);
2370 SvCUR_set(argsv, need);
a0d0e21e
LW
2371 }
2372
748a9306 2373 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
2374 }
2375 else {
748a9306 2376 retval = SvIV(argsv);
c529f79d 2377 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW
2378 }
2379
49225470 2380 optype = PL_op->op_type;
ed4b2e6b 2381 TAINT_PROPER(PL_op_desc[optype]);
a0d0e21e
LW
2382
2383 if (optype == OP_IOCTL)
2384#ifdef HAS_IOCTL
76e3520e 2385 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2386#else
cea2e8a9 2387 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW
2388#endif
2389 else
c214f4ad
B
2390#ifndef HAS_FCNTL
2391 DIE(aTHX_ "fcntl is not implemented");
2392#else
55497cff 2393#if defined(OS2) && defined(__EMX__)
760ac839 2394 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2395#else
760ac839 2396 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2397#endif
6652bd42 2398#endif
a0d0e21e 2399
6652bd42 2400#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
748a9306
LW
2401 if (SvPOK(argsv)) {
2402 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2403 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2404 OP_NAME(PL_op));
748a9306
LW
2405 s[SvCUR(argsv)] = 0; /* put our null back */
2406 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
2407 }
2408
2409 if (retval == -1)
2410 RETPUSHUNDEF;
2411 if (retval != 0) {
2412 PUSHi(retval);
2413 }
2414 else {
8903cb82 2415 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2416 }
4808266b 2417#endif
c214f4ad 2418 RETURN;
a0d0e21e
LW
2419}
2420
2421PP(pp_flock)
2422{
9cad6237 2423#ifdef FLOCK
20b7effb 2424 dSP; dTARGET;
a0d0e21e 2425 I32 value;
7452cf6a 2426 const int argtype = POPi;
1f28cbca 2427 GV * const gv = MUTABLE_GV(POPs);
9c9f25b8
NC
2428 IO *const io = GvIO(gv);
2429 PerlIO *const fp = io ? IoIFP(io) : NULL;
16d20bd9 2430
0bcc34c2 2431 /* XXX Looks to me like io is always NULL at this point */
a0d0e21e 2432 if (fp) {
68dc0745 2433 (void)PerlIO_flush(fp);
76e3520e 2434 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2435 }
cb50131a 2436 else {
51087808 2437 report_evil_fh(gv);
a0d0e21e 2438 value = 0;
93189314 2439 SETERRNO(EBADF,RMS_IFI);
cb50131a 2440 }
a0d0e21e
LW
2441 PUSHi(value);
2442 RETURN;
2443#else
56a94ef2 2444 DIE(aTHX_ PL_no_func, "flock");
a0d0e21e
LW
2445#endif
2446}
2447
2448/* Sockets. */
2449
7627e6d0
NC
2450#ifdef HAS_SOCKET
2451
a0d0e21e
LW
2452PP(pp_socket)
2453{
20b7effb 2454 dSP;
7452cf6a
AL
2455 const int protocol = POPi;
2456 const int type = POPi;
2457 const int domain = POPi;
159b6efe 2458 GV * const gv = MUTABLE_GV(POPs);
5805b585 2459 IO * const io = GvIOn(gv);
a0d0e21e
LW
2460 int fd;
2461
57171420
BS
2462 if (IoIFP(io))
2463 do_close(gv, FALSE);
2464
a0d0e21e 2465 TAINT_PROPER("socket");
6ad3d225 2466 fd = PerlSock_socket(domain, type, protocol);
375ed12a
JH
2467 if (fd < 0) {
2468 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 2469 RETPUSHUNDEF;
375ed12a 2470 }
460c8493
IZ
2471 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2472 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2473 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2474 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
2475 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2476 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2477 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
2478 RETPUSHUNDEF;
2479 }
8d2a6795 2480#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH
2481 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2482 RETPUSHUNDEF;
8d2a6795 2483#endif
a0d0e21e
LW
2484
2485 RETPUSHYES;
a0d0e21e 2486}
7627e6d0 2487#endif
a0d0e21e
LW
2488
2489PP(pp_sockpair)
2490{
c95c94b1 2491#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
20b7effb 2492 dSP;
e0b7b5e2 2493 int fd[2];
7452cf6a
AL
2494 const int protocol = POPi;
2495 const int type = POPi;
2496 const int domain = POPi;
e0b7b5e2 2497
159b6efe 2498 GV * const gv2 = MUTABLE_GV(POPs);
49561e08
FC
2499 IO * const io2 = GvIOn(gv2);
2500 GV * const gv1 = MUTABLE_GV(POPs);
2501 IO * const io1 = GvIOn(gv1);
a0d0e21e 2502
49561e08 2503 if (IoIFP(io1))
dc0d0a5f 2504 do_close(gv1, FALSE);
49561e08 2505 if (IoIFP(io2))
dc0d0a5f 2506 do_close(gv2, FALSE);
57171420 2507
a0d0e21e 2508 TAINT_PROPER("socketpair");
6ad3d225 2509 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2510 RETPUSHUNDEF;
460c8493
IZ
2511 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2512 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
50952442 2513 IoTYPE(io1) = IoTYPE_SOCKET;
460c8493
IZ
2514 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2515 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
50952442 2516 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2517 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW
2518 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2519 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2520 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW
2521 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2522 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2523 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW
2524 RETPUSHUNDEF;
2525 }
8d2a6795 2526#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH
2527 /* ensure close-on-exec */
2528 if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
2529 (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
2530 RETPUSHUNDEF;
8d2a6795 2531#endif
a0d0e21e
LW
2532
2533 RETPUSHYES;
2534#else
cea2e8a9 2535 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW
2536#endif
2537}
2538
7627e6d0
NC
2539#ifdef HAS_SOCKET
2540
b1c05ba5
DM
2541/* also used for: pp_connect() */
2542
a0d0e21e
LW
2543PP(pp_bind)
2544{
20b7effb 2545 dSP;
7452cf6a 2546 SV * const addrsv = POPs;
349d4f2f
NC
2547 /* OK, so on what platform does bind modify addr? */
2548 const char *addr;
159b6efe 2549 GV * const gv = MUTABLE_GV(POPs);
eb578fdb 2550 IO * const io = GvIOn(gv);
a0d0e21e 2551 STRLEN len;
e0b7b5e2 2552 int op_type;
375ed12a 2553 int fd;
a0d0e21e 2554
8a6c0fcb 2555 if (!IoIFP(io))
a0d0e21e 2556 goto nuts;
375ed12a
JH
2557 fd = PerlIO_fileno(IoIFP(io));
2558 if (fd < 0)
2559 goto nuts;
a0d0e21e 2560
349d4f2f 2561 addr = SvPV_const(addrsv, len);
e0b7b5e2 2562 op_type = PL_op->op_type;
32b81f04
NC
2563 TAINT_PROPER(PL_op_desc[op_type]);
2564 if ((op_type == OP_BIND
375ed12a
JH
2565 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
2566 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
32b81f04 2567 >= 0)
a0d0e21e
LW
2568 RETPUSHYES;
2569 else
2570 RETPUSHUNDEF;
2571
7b52d656 2572 nuts:
fbcda526 2573 report_evil_fh(gv);
93189314 2574 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2575 RETPUSHUNDEF;
a0d0e21e
LW
2576}
2577
2578PP(pp_listen)
2579{
20b7effb 2580 dSP;
7452cf6a 2581 const int backlog = POPi;
159b6efe 2582 GV * const gv = MUTABLE_GV(POPs);
8a6c0fcb 2583 IO * const io = GvIOn(gv);
a0d0e21e 2584
8a6c0fcb 2585 if (!IoIFP(io))
a0d0e21e
LW
2586 goto nuts;
2587
6ad3d225 2588 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW
2589 RETPUSHYES;
2590 else
2591 RETPUSHUNDEF;
2592
7b52d656 2593 nuts:
fbcda526 2594 report_evil_fh(gv);
93189314 2595 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2596 RETPUSHUNDEF;
a0d0e21e
LW
2597}
2598
2599PP(pp_accept)
2600{
20b7effb 2601 dSP; dTARGET;
eb578fdb 2602 IO *nstio;
93d47a36 2603 char namebuf[MAXPATHLEN];
b5afd346 2604#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
93d47a36
JH
2605 Sock_size_t len = sizeof (struct sockaddr_in);
2606#else
2607 Sock_size_t len = sizeof namebuf;
2608#endif
159b6efe
NC
2609 GV * const ggv = MUTABLE_GV(POPs);
2610 GV * const ngv = MUTABLE_GV(POPs);
a0d0e21e
LW
2611 int fd;
2612
8a6c0fcb 2613 IO * const gstio = GvIO(ggv);
a0d0e21e
LW
2614 if (!gstio || !IoIFP(gstio))
2615 goto nuts;
2616
2617 nstio = GvIOn(ngv);
93d47a36 2618 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
e294cc5d
JH
2619#if defined(OEMVS)
2620 if (len == 0) {
2621 /* Some platforms indicate zero length when an AF_UNIX client is
2622 * not bound. Simulate a non-zero-length sockaddr structure in
2623 * this case. */
2624 namebuf[0] = 0; /* sun_len */
2625 namebuf[1] = AF_UNIX; /* sun_family */
2626 len = 2;
2627 }
2628#endif
2629
a0d0e21e
LW
2630 if (fd < 0)
2631 goto badexit;
a70048fb
AB
2632 if (IoIFP(nstio))
2633 do_close(ngv, FALSE);
460c8493
IZ
2634 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2635 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2636 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2637 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW
2638 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2639 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2640 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW
2641 goto badexit;
2642 }
8d2a6795 2643#if defined(HAS_FCNTL) && defined(F_SETFD)
375ed12a
JH
2644 if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
2645 goto badexit;
8d2a6795 2646#endif
a0d0e21e 2647
381c1bae 2648#ifdef __SCO_VERSION__
93d47a36 2649 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
381c1bae 2650#endif
ed79a026 2651
93d47a36 2652 PUSHp(namebuf, len);
a0d0e21e
LW
2653 RETURN;
2654
7b52d656 2655 nuts:
fbcda526 2656 report_evil_fh(ggv);
93189314 2657 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2658
7b52d656 2659 badexit:
a0d0e21e
LW
2660 RETPUSHUNDEF;
2661
a0d0e21e
LW
2662}
2663
2664PP(pp_shutdown)
2665{
20b7effb 2666 dSP; dTARGET;
7452cf6a 2667 const int how = POPi;
159b6efe 2668 GV * const gv = MUTABLE_GV(POPs);
eb578fdb 2669 IO * const io = GvIOn(gv);
a0d0e21e 2670
8a6c0fcb 2671 if (!IoIFP(io))
a0d0e21e
LW
2672 goto nuts;
2673
6ad3d225 2674 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW
2675 RETURN;
2676
7b52d656 2677 nuts:
fbcda526 2678 report_evil_fh(gv);
93189314 2679 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2680 RETPUSHUNDEF;
a0d0e21e
LW
2681}
2682
b1c05ba5
DM
2683
2684/* also used for: pp_gsockopt() */
2685
a0d0e21e
LW
2686PP(pp_ssockopt)
2687{
20b7effb 2688 dSP;
7452cf6a 2689 const int optype = PL_op->op_type;
561b68a9 2690 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
7452cf6a
AL
2691 const unsigned int optname = (unsigned int) POPi;
2692 const unsigned int lvl = (unsigned int) POPi;
159b6efe 2693 GV * const gv = MUTABLE_GV(POPs);
eb578fdb 2694 IO * const io = GvIOn(gv);
a0d0e21e 2695 int fd;
1e422769 2696 Sock_size_t len;
a0d0e21e 2697
49225470 2698 if (!IoIFP(io))
a0d0e21e
LW
2699 goto nuts;
2700
760ac839 2701 fd = PerlIO_fileno(IoIFP(io));
375ed12a
JH
2702 if (fd < 0)
2703 goto nuts;
a0d0e21e
LW
2704 switch (optype) {
2705 case OP_GSOCKOPT:
748a9306 2706 SvGROW(sv, 257);
a0d0e21e 2707 (void)SvPOK_only(sv);
748a9306
LW
2708 SvCUR_set(sv,256);
2709 *SvEND(sv) ='\0';
1e422769 2710 len = SvCUR(sv);
6ad3d225 2711 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2712 goto nuts2;
ee2276e5
JH
2713#if defined(_AIX)
2714 /* XXX Configure test: does getsockopt set the length properly? */
2715 if (len == 256)
2716 len = sizeof(int);
2717#endif
1e422769 2718 SvCUR_set(sv, len);
748a9306 2719 *SvEND(sv) ='\0';
a0d0e21e
LW
2720 PUSHs(sv);
2721 break;
2722 case OP_SSOCKOPT: {
1215b447
JH
2723#if defined(__SYMBIAN32__)
2724# define SETSOCKOPT_OPTION_VALUE_T void *
2725#else
2726# define SETSOCKOPT_OPTION_VALUE_T const char *
2727#endif
2728 /* XXX TODO: We need to have a proper type (a Configure probe,
2729 * etc.) for what the C headers think of the third argument of
2730 * setsockopt(), the option_value read-only buffer: is it
2731 * a "char *", or a "void *", const or not. Some compilers
2732 * don't take kindly to e.g. assuming that "char *" implicitly
2733 * promotes to a "void *", or to explicitly promoting/demoting
2734 * consts to non/vice versa. The "const void *" is the SUS
2735 * definition, but that does not fly everywhere for the above
2736 * reasons. */
2737 SETSOCKOPT_OPTION_VALUE_T buf;
1e422769
PP
2738 int aint;
2739 if (SvPOKp(sv)) {
2d8e6c8d 2740 STRLEN l;
1215b447 2741 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2d8e6c8d 2742 len = l;
1e422769 2743 }
56ee1660 2744 else {
a0d0e21e 2745 aint = (int)SvIV(sv);
1215b447 2746 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
a0d0e21e
LW
2747 len = sizeof(int);
2748 }
6ad3d225 2749 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2750 goto nuts2;
3280af22 2751 PUSHs(&PL_sv_yes);
a0d0e21e
LW
2752 }
2753 break;
2754 }
2755 RETURN;
2756
7b52d656 2757 nuts:
fbcda526 2758 report_evil_fh(gv);
93189314 2759 SETERRNO(EBADF,SS_IVCHAN);
7b52d656 2760 nuts2:
a0d0e21e
LW
2761 RETPUSHUNDEF;
2762
a0d0e21e
LW
2763}
2764
b1c05ba5
DM
2765
2766/* also used for: pp_getsockname() */
2767
a0d0e21e
LW
2768PP(pp_getpeername)
2769{
20b7effb 2770 dSP;
7452cf6a 2771 const int optype = PL_op->op_type;
159b6efe 2772 GV * const gv = MUTABLE_GV(POPs);
eb578fdb 2773 IO * const io = GvIOn(gv);
7452cf6a 2774 Sock_size_t len;
a0d0e21e
LW
2775 SV *sv;
2776 int fd;
a0d0e21e 2777
49225470 2778 if (!IoIFP(io))
a0d0e21e
LW
2779 goto nuts;
2780
561b68a9 2781 sv = sv_2mortal(newSV(257));
748a9306 2782 (void)SvPOK_only(sv);
1e422769
PP
2783 len = 256;
2784 SvCUR_set(sv, len);
748a9306 2785 *SvEND(sv) ='\0';
760ac839 2786 fd = PerlIO_fileno(IoIFP(io));
375ed12a
JH
2787 if (fd < 0)
2788 goto nuts;
a0d0e21e
LW
2789 switch (optype) {
2790 case OP_GETSOCKNAME:
6ad3d225 2791 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW
2792 goto nuts2;
2793 break;
2794 case OP_GETPEERNAME:
6ad3d225 2795 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2796 goto nuts2;
490ab354
JH
2797#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2798 {
2799 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";
2800 /* If the call succeeded, make sure we don't have a zeroed port/addr */
349d4f2f 2801 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2fbb330f 2802 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
490ab354 2803 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2804 goto nuts2;
490ab354
JH
2805 }
2806 }
2807#endif
a0d0e21e
LW
2808 break;
2809 }
13826f2c
CS
2810#ifdef BOGUS_GETNAME_RETURN
2811 /* Interactive Unix, getpeername() and getsockname()
2812 does not return valid namelen */
1e422769
PP
2813 if (len == BOGUS_GETNAME_RETURN)
2814 len = sizeof(struct sockaddr);
13826f2c 2815#endif
1e422769 2816 SvCUR_set(sv, len);
748a9306 2817 *SvEND(sv) ='\0';
a0d0e21e
LW
2818 PUSHs(sv);
2819 RETURN;
2820
7b52d656 2821 nuts:
fbcda526 2822 report_evil_fh(gv);
93189314 2823 SETERRNO(EBADF,SS_IVCHAN);
7b52d656 2824 nuts2:
a0d0e21e 2825 RETPUSHUNDEF;
7627e6d0 2826}
a0d0e21e 2827
a0d0e21e 2828#endif
a0d0e21e
LW
2829
2830/* Stat calls. */
2831
b1c05ba5
DM
2832/* also used for: pp_lstat() */
2833
a0d0e21e
LW
2834PP(pp_stat)
2835{
39644a26 2836 dSP;
10edeb5d 2837 GV *gv = NULL;
55dd8d50 2838 IO *io = NULL;
54310121 2839 I32 gimme;
a0d0e21e 2840 I32 max = 13;
109c43ed 2841 SV* sv;
a0d0e21e 2842
109c43ed
FC
2843 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2844 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
8a4e5b40 2845 if (PL_op->op_type == OP_LSTAT) {
5d3e98de 2846 if (gv != PL_defgv) {
5d329e6e 2847 do_fstat_warning_check:
a2a5de95 2848 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
93fad930
FC
2849 "lstat() on filehandle%s%"SVf,
2850 gv ? " " : "",
2851 SVfARG(gv
bf29d05f
BF
2852 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2853 : &PL_sv_no));
5d3e98de 2854 } else if (PL_laststype != OP_LSTAT)
b042df57 2855 /* diag_listed_as: The stat preceding %s wasn't an lstat */
8a4e5b40 2856 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
8a4e5b40
DD
2857 }
2858
2dd78f96 2859 if (gv != PL_defgv) {
b8413ac3 2860 bool havefp;
0d5064f1 2861 do_fstat_have_io:
b8413ac3 2862 havefp = FALSE;
3280af22 2863 PL_laststype = OP_STAT;
0d5064f1 2864 PL_statgv = gv ? gv : (GV *)io;
76f68e9b 2865 sv_setpvs(PL_statname, "");
5228a96c 2866 if(gv) {
ad02613c 2867 io = GvIO(gv);
0d5064f1
FC
2868 }
2869 if (io) {
5228a96c 2870 if (IoIFP(io)) {
375ed12a
JH
2871 int fd = PerlIO_fileno(IoIFP(io));
2872 if (fd < 0) {
2873 PL_laststatval = -1;
2874 SETERRNO(EBADF,RMS_IFI);
2875 } else {
2876 PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
2877 havefp = TRUE;
2878 }
5228a96c 2879 } else if (IoDIRP(io)) {
5228a96c 2880 PL_laststatval =
3497a01f 2881 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
8080e3c8 2882 havefp = TRUE;
5228a96c
SP
2883 } else {
2884 PL_laststatval = -1;
2885 }
5228a96c 2886 }
05bb32d2 2887 else PL_laststatval = -1;
daa30a68 2888 if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
5228a96c
SP
2889 }
2890
9ddeeac9 2891 if (PL_laststatval < 0) {
a0d0e21e 2892 max = 0;
9ddeeac9 2893 }
a0d0e21e
LW
2894 }
2895 else {
7cb3f959 2896 const char *file;
109c43ed 2897 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2898 io = MUTABLE_IO(SvRV(sv));
ad02613c
SP
2899 if (PL_op->op_type == OP_LSTAT)
2900 goto do_fstat_warning_check;
2901 goto do_fstat_have_io;
2902 }
2903
4bac9ae4 2904 SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
109c43ed 2905 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
a0714e2c 2906 PL_statgv = NULL;
533c011a 2907 PL_laststype = PL_op->op_type;
7cb3f959 2908 file = SvPV_nolen_const(PL_statname);
533c011a 2909 if (PL_op->op_type == OP_LSTAT)
7cb3f959 2910 PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
a0d0e21e 2911 else
7cb3f959 2912 PL_laststatval = PerlLIO_stat(file, &PL_statcache);
3280af22 2913 if (PL_laststatval < 0) {
7cb3f959 2914 if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
5d37acd6
DM
2915 /* PL_warn_nl is constant */
2916 GCC_DIAG_IGNORE(-Wformat-nonliteral);
9014280d 2917 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
5d37acd6
DM
2918 GCC_DIAG_RESTORE;
2919 }
a0d0e21e
LW
2920 max = 0;
2921 }
2922 }
2923
54310121
PP
2924 gimme = GIMME_V;
2925 if (gimme != G_ARRAY) {
2926 if (gimme != G_VOID)
2927 XPUSHs(boolSV(max));
2928 RETURN;
a0d0e21e
LW
2929 }
2930 if (max) {
36477c24
PP
2931 EXTEND(SP, max);
2932 EXTEND_MORTAL(max);
6e449a3a 2933 mPUSHi(PL_statcache.st_dev);
8d8cba88
TC
2934#if ST_INO_SIZE > IVSIZE
2935 mPUSHn(PL_statcache.st_ino);
2936#else
2937# if ST_INO_SIGN <= 0
6e449a3a 2938 mPUSHi(PL_statcache.st_ino);
8d8cba88
TC
2939# else
2940 mPUSHu(PL_statcache.st_ino);
2941# endif
2942#endif
6e449a3a
MHM
2943 mPUSHu(PL_statcache.st_mode);
2944 mPUSHu(PL_statcache.st_nlink);
dfff4baf
BF
2945
2946 sv_setuid(PUSHmortal, PL_statcache.st_uid);
2947 sv_setgid(PUSHmortal, PL_statcache.st_gid);
2948
cbdc8872 2949#ifdef USE_STAT_RDEV
6e449a3a 2950 mPUSHi(PL_statcache.st_rdev);
cbdc8872 2951#else
84bafc02 2952 PUSHs(newSVpvs_flags("", SVs_TEMP));
cbdc8872 2953#endif
146174a9 2954#if Off_t_size > IVSIZE
6e449a3a 2955 mPUSHn(PL_statcache.st_size);
146174a9 2956#else
6e449a3a 2957 mPUSHi(PL_statcache.st_size);
146174a9 2958#endif
cbdc8872 2959#ifdef BIG_TIME
6e449a3a
MHM
2960 mPUSHn(PL_statcache.st_atime);
2961 mPUSHn(PL_statcache.st_mtime);
2962 mPUSHn(PL_statcache.st_ctime);
cbdc8872 2963#else
6e449a3a
MHM
2964 mPUSHi(PL_statcache.st_atime);
2965 mPUSHi(PL_statcache.st_mtime);
2966 mPUSHi(PL_statcache.st_ctime);
cbdc8872 2967#endif
a0d0e21e 2968#ifdef USE_STAT_BLOCKS
6e449a3a
MHM
2969 mPUSHu(PL_statcache.st_blksize);
2970 mPUSHu(PL_statcache.st_blocks);
a0d0e21e 2971#else
84bafc02
NC
2972 PUSHs(newSVpvs_flags("", SVs_TEMP));
2973 PUSHs(newSVpvs_flags("", SVs_TEMP));
a0d0e21e
LW
2974#endif
2975 }
2976 RETURN;
2977}
2978
6c48f025
NC
2979/* All filetest ops avoid manipulating the perl stack pointer in their main
2980 bodies (since commit d2c4d2d1e22d3125), and return using either
2981 S_ft_return_false() or S_ft_return_true(). These two helper functions are
2982 the only two which manipulate the perl stack. To ensure that no stack
2983 manipulation macros are used, the filetest ops avoid defining a local copy
2984 of the stack pointer with dSP. */
2985
8db8f6b6
FC
2986/* If the next filetest is stacked up with this one
2987 (PL_op->op_private & OPpFT_STACKING), we leave
2988 the original argument on the stack for success,
2989 and skip the stacked operators on failure.
2990 The next few macros/functions take care of this.
2991*/
2992
2993static OP *
9a6b02e8 2994S_ft_return_false(pTHX_ SV *ret) {
8db8f6b6 2995 OP *next = NORMAL;
697f9d37
NC
2996 dSP;
2997
226b9201 2998 if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
8db8f6b6
FC
2999 else SETs(ret);
3000 PUTBACK;
697f9d37 3001
9a6b02e8
NC
3002 if (PL_op->op_private & OPpFT_STACKING) {
3003 while (OP_IS_FILETEST(next->op_type)
3004 && next->op_private & OPpFT_STACKED)
3005 next = next->op_next;
3006 }
8db8f6b6
FC
3007 return next;
3008}
3009
07ed4d4b
NC
3010PERL_STATIC_INLINE OP *
3011S_ft_return_true(pTHX_ SV *ret) {
3012 dSP;
3013 if (PL_op->op_flags & OPf_REF)
3014 XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
3015 else if (!(PL_op->op_private & OPpFT_STACKING))
3016 SETs(ret);
3017 PUTBACK;
3018 return NORMAL;
3019}
8db8f6b6 3020
48d023d6
NC
3021#define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
3022#define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
3023#define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
8db8f6b6 3024
6f1401dc 3025#define tryAMAGICftest_MG(chr) STMT_START { \
d2f67720 3026 if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
8db8f6b6
FC
3027 && PL_op->op_flags & OPf_KIDS) { \
3028 OP *next = S_try_amagic_ftest(aTHX_ chr); \
3029 if (next) return next; \
3030 } \
6f1401dc
DM
3031 } STMT_END
3032
8db8f6b6 3033STATIC OP *
6f1401dc 3034S_try_amagic_ftest(pTHX_ char chr) {
d2f67720 3035 SV *const arg = *PL_stack_sp;
6f1401dc
DM
3036
3037 assert(chr != '?');
c5780028 3038 if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
6f1401dc 3039
d2f67720 3040 if (SvAMAGIC(arg))
6f1401dc
DM
3041 {
3042 const char tmpchr = chr;
6f1401dc
DM
3043 SV * const tmpsv = amagic_call(arg,
3044 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
3045 ftest_amg, AMGf_unary);
3046
3047 if (!tmpsv)
8db8f6b6 3048 return NULL;
6f1401dc 3049
48d023d6
NC
3050 return SvTRUE(tmpsv)
3051 ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
6f1401dc 3052 }
8db8f6b6 3053 return NULL;
6f1401dc
DM
3054}
3055
3056
b1c05ba5
DM
3057/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec()
3058 * pp_ftrwrite() */
3059
a0d0e21e
LW
3060PP(pp_ftrread)
3061{
9cad6237 3062 I32 result;
af9e49b4 3063 /* Not const, because things tweak this below. Not bool, because there's
f3574cc6 3064 no guarantee that OPpFT_ACCESS is <= CHAR_MAX */
af9e49b4
NC
3065#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3066 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3067 /* Giving some sort of initial value silences compilers. */
3068# ifdef R_OK
3069 int access_mode = R_OK;
3070# else
3071 int access_mode = 0;
3072# endif
5ff3f7a4 3073#else
af9e49b4
NC
3074 /* access_mode is never used, but leaving use_access in makes the
3075 conditional compiling below much clearer. */
3076 I32 use_access = 0;
5ff3f7a4 3077#endif
2dcac756 3078 Mode_t stat_mode = S_IRUSR;
a0d0e21e 3079
af9e49b4 3080 bool effective = FALSE;
07fe7c6a 3081 char opchar = '?';
af9e49b4 3082
7fb13887
BM
3083 switch (PL_op->op_type) {
3084 case OP_FTRREAD: opchar = 'R'; break;
3085 case OP_FTRWRITE: opchar = 'W'; break;
3086 case OP_FTREXEC: opchar = 'X'; break;
3087 case OP_FTEREAD: opchar = 'r'; break;
3088 case OP_FTEWRITE: opchar = 'w'; break;
3089 case OP_FTEEXEC: opchar = 'x'; break;
3090 }
6f1401dc 3091 tryAMAGICftest_MG(opchar);
7fb13887 3092
af9e49b4
NC
3093 switch (PL_op->op_type) {
3094 case OP_FTRREAD:
3095#if !(defined(HAS_ACCESS) && defined(R_OK))
3096 use_access = 0;
3097#endif
3098 break;
3099
3100 case OP_FTRWRITE:
5ff3f7a4 3101#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 3102 access_mode = W_OK;
5ff3f7a4 3103#else
af9e49b4 3104 use_access = 0;
5ff3f7a4 3105#endif
af9e49b4
NC
3106 stat_mode = S_IWUSR;
3107 break;
a0d0e21e 3108
af9e49b4 3109 case OP_FTREXEC:
5ff3f7a4 3110#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 3111 access_mode = X_OK;
5ff3f7a4 3112#else
af9e49b4 3113 use_access = 0;
5ff3f7a4 3114#endif
af9e49b4
NC
3115 stat_mode = S_IXUSR;
3116 break;
a0d0e21e 3117
af9e49b4 3118 case OP_FTEWRITE:
faee0e31 3119#ifdef PERL_EFF_ACCESS
af9e49b4 3120 access_mode = W_OK;
5ff3f7a4 3121#endif
af9e49b4 3122 stat_mode = S_IWUSR;
924ba076 3123 /* FALLTHROUGH */
a0d0e21e 3124
af9e49b4
NC
3125 case OP_FTEREAD:
3126#ifndef PERL_EFF_ACCESS
3127 use_access = 0;
3128#endif
3129 effective = TRUE;
3130 break;
3131
af9e49b4 3132 case OP_FTEEXEC:
faee0e31 3133#ifdef PERL_EFF_ACCESS
b376053d 3134 access_mode = X_OK;
5ff3f7a4 3135#else
af9e49b4 3136 use_access = 0;
5ff3f7a4 3137#endif
af9e49b4
NC
3138 stat_mode = S_IXUSR;
3139 effective = TRUE;
3140 break;
3141 }
a0d0e21e 3142
af9e49b4
NC
3143 if (use_access) {
3144#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
d2f67720 3145 const char *name = SvPV_nolen(*PL_stack_sp);
af9e49b4
NC
3146 if (effective) {
3147# ifdef PERL_EFF_ACCESS
3148 result = PERL_EFF_ACCESS(name, access_mode);
3149# else
3150 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3151 OP_NAME(PL_op));
3152# endif
3153 }
3154 else {
3155# ifdef HAS_ACCESS
3156 result = access(name, access_mode);
3157# else
3158 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3159# endif
3160 }
5ff3f7a4 3161 if (result == 0)
d2c4d2d1 3162 FT_RETURNYES;
5ff3f7a4 3163 if (result < 0)
d2c4d2d1
FC
3164 FT_RETURNUNDEF;
3165 FT_RETURNNO;
af9e49b4 3166#endif
22865c03 3167 }
af9e49b4 3168
40c852de 3169 result = my_stat_flags(0);
a0d0e21e 3170 if (result < 0)
8db8f6b6 3171 FT_RETURNUNDEF;
af9e49b4 3172 if (cando(stat_mode, effective, &PL_statcache))
8db8f6b6
FC
3173 FT_RETURNYES;
3174 FT_RETURNNO;
a0d0e21e
LW
3175}
3176
b1c05ba5
DM
3177
3178/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */
3179
a0d0e21e
LW
3180PP(pp_ftis)
3181{
fbb0b3b3 3182 I32 result;
d7f0a2f4 3183 const int op_type = PL_op->op_type;
07fe7c6a 3184 char opchar = '?';
07fe7c6a
BM
3185
3186 switch (op_type) {
3187 case OP_FTIS: opchar = 'e'; break;
3188 case OP_FTSIZE: opchar = 's'; break;
3189 case OP_FTMTIME: opchar = 'M'; break;
3190 case OP_FTCTIME: opchar = 'C'; break;
3191 case OP_FTATIME: opchar = 'A'; break;
3192 }
6f1401dc 3193 tryAMAGICftest_MG(opchar);
07fe7c6a 3194
40c852de 3195 result = my_stat_flags(0);
a0d0e21e 3196 if (result < 0)
8db8f6b6 3197 FT_RETURNUNDEF;
d7f0a2f4 3198 if (op_type == OP_FTIS)
8db8f6b6 3199 FT_RETURNYES;
957b0e1d 3200 {
d7f0a2f4
NC
3201 /* You can't dTARGET inside OP_FTIS, because you'll get
3202 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3203 dTARGET;
d7f0a2f4 3204 switch (op_type) {
957b0e1d
NC
3205 case OP_FTSIZE:
3206#if Off_t_size > IVSIZE
8db8f6b6 3207 sv_setnv(TARG, (NV)PL_statcache.st_size);
957b0e1d 3208#else
8db8f6b6 3209 sv_setiv(TARG, (IV)PL_statcache.st_size);
957b0e1d
NC
3210#endif
3211 break;
3212 case OP_FTMTIME:
8db8f6b6
FC
3213 sv_setnv(TARG,
3214 ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
957b0e1d
NC
3215 break;
3216 case OP_FTATIME:
8db8f6b6
FC
3217 sv_setnv(TARG,
3218 ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
957b0e1d
NC
3219 break;
3220 case OP_FTCTIME:
8db8f6b6
FC
3221 sv_setnv(TARG,
3222 ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
957b0e1d
NC
3223 break;
3224 }
8db8f6b6 3225 SvSETMAGIC(TARG);
48d023d6
NC
3226 return SvTRUE_nomg(TARG)
3227 ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
957b0e1d 3228 }
a0d0e21e
LW
3229}
3230
b1c05ba5
DM
3231
3232/* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned()
3233 * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock()
3234 * pp_ftsuid() pp_ftsvtx() pp_ftzero() */
3235
a0d0e21e
LW
3236PP(pp_ftrowned)
3237{
fbb0b3b3 3238 I32 result;
07fe7c6a 3239 char opchar = '?';
17ad201a 3240
7fb13887
BM
3241 switch (PL_op->op_type) {
3242 case OP_FTROWNED: opchar = 'O'; break;
3243 case OP_FTEOWNED: opchar = 'o'; break;
3244 case OP_FTZERO: opchar = 'z'; break;
3245 case OP_FTSOCK: opchar = 'S'; break;
3246 case OP_FTCHR: opchar = 'c'; break;
3247 case OP_FTBLK: opchar = 'b'; break;
3248 case OP_FTFILE: opchar = 'f'; break;
3249 case OP_FTDIR: opchar = 'd'; break;
3250 case OP_FTPIPE: opchar = 'p'; break;
3251 case OP_FTSUID: opchar = 'u'; break;
3252 case OP_FTSGID: opchar = 'g'; break;
3253 case OP_FTSVTX: opchar = 'k'; break;
3254 }
6f1401dc 3255 tryAMAGICftest_MG(opchar);
7fb13887 3256
17ad201a
NC
3257 /* I believe that all these three are likely to be defined on most every
3258 system these days. */
3259#ifndef S_ISUID
c410dd6a 3260 if(PL_op->op_type == OP_FTSUID) {
8db8f6b6 3261 FT_RETURNNO;
c410dd6a 3262 }
17ad201a
NC
3263#endif
3264#ifndef S_ISGID
c410dd6a 3265 if(PL_op->op_type == OP_FTSGID) {
8db8f6b6 3266 FT_RETURNNO;
c410dd6a 3267 }
17ad201a
NC
3268#endif
3269#ifndef S_ISVTX
c410dd6a 3270 if(PL_op->op_type == OP_FTSVTX) {
8db8f6b6 3271 FT_RETURNNO;
c410dd6a 3272 }
17ad201a
NC
3273#endif
3274
40c852de 3275 result = my_stat_flags(0);
a0d0e21e 3276 if (result < 0)
8db8f6b6 3277 FT_RETURNUNDEF;
f1cb2d48
NC
3278 switch (PL_op->op_type) {
3279 case OP_FTROWNED:
985213f2 3280 if (PL_statcache.st_uid == PerlProc_getuid())
8db8f6b6 3281 FT_RETURNYES;
f1cb2d48
NC
3282 break;
3283 case OP_FTEOWNED:
985213f2 3284 if (PL_statcache.st_uid == PerlProc_geteuid())
8db8f6b6 3285 FT_RETURNYES;
f1cb2d48
NC
3286 break;
3287 case OP_FTZERO:
3288 if (PL_statcache.st_size == 0)
8db8f6b6 3289 FT_RETURNYES;
f1cb2d48
NC
3290 break;
3291 case OP_FTSOCK:
3292 if (S_ISSOCK(PL_statcache.st_mode))
8db8f6b6 3293 FT_RETURNYES;
f1cb2d48
NC
3294 break;
3295 case OP_FTCHR:
3296 if (S_ISCHR(PL_statcache.st_mode))
8db8f6b6 3297 FT_RETURNYES;
f1cb2d48
NC
3298 break;
3299 case OP_FTBLK:
3300 if (S_ISBLK(PL_statcache.st_mode))
8db8f6b6 3301 FT_RETURNYES;
f1cb2d48
NC
3302 break;
3303 case OP_FTFILE:
3304 if (S_ISREG(PL_statcache.st_mode))
8db8f6b6 3305 FT_RETURNYES;
f1cb2d48
NC
3306 break;
3307 case OP_FTDIR:
3308 if (S_ISDIR(PL_statcache.st_mode))
8db8f6b6 3309 FT_RETURNYES;
f1cb2d48
NC
3310 break;
3311 case OP_FTPIPE:
3312 if (S_ISFIFO(PL_statcache.st_mode))
8db8f6b6 3313 FT_RETURNYES;
f1cb2d48 3314 break;
a0d0e21e 3315#ifdef S_ISUID
17ad201a
NC
3316 case OP_FTSUID:
3317 if (PL_statcache.st_mode & S_ISUID)
8db8f6b6 3318 FT_RETURNYES;
17ad201a 3319 break;
a0d0e21e 3320#endif
a0d0e21e 3321#ifdef S_ISGID
17ad201a
NC
3322 case OP_FTSGID:
3323 if (PL_statcache.st_mode & S_ISGID)
8db8f6b6 3324 FT_RETURNYES;
17ad201a
NC
3325 break;
3326#endif
3327#ifdef S_ISVTX
3328 case OP_FTSVTX:
3329 if (PL_statcache.st_mode & S_ISVTX)
8db8f6b6 3330 FT_RETURNYES;
17ad201a 3331 break;
a0d0e21e 3332#endif
17ad201a 3333 }
8db8f6b6 3334 FT_RETURNNO;
a0d0e21e
LW
3335}
3336
17ad201a 3337PP(pp_ftlink)
a0d0e21e 3338{
500ff13f 3339 I32 result;
07fe7c6a 3340
6f1401dc 3341 tryAMAGICftest_MG('l');
40c852de 3342 result = my_lstat_flags(0);
500ff13f 3343
a0d0e21e 3344 if (result < 0)
8db8f6b6 3345 FT_RETURNUNDEF;
17ad201a 3346 if (S_ISLNK(PL_statcache.st_mode))
8db8f6b6
FC
3347 FT_RETURNYES;
3348 FT_RETURNNO;
a0d0e21e
LW
3349}
3350
3351PP(pp_fttty)
3352{
a0d0e21e
LW
3353 int fd;
3354 GV *gv;
0784aae0 3355 char *name = NULL;
40c852de 3356 STRLEN namelen;
22ff3130 3357 UV uv;
fb73857a 3358
6f1401dc 3359 tryAMAGICftest_MG('t');
07fe7c6a