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