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