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