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