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