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