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