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