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