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