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