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