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