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