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