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