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