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
As report_wrongway_fh() checks ckWARN(WARN_IO) internally, don't duplicate this.
[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.
702 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 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))) {
c289d2f7 775 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 776 report_evil_fh(gv);
b5fe5ca2 777 SETERRNO(EBADF,RMS_IFI);
50f846a7
SC		 778 RETPUSHUNDEF;
779 }
a0d0e21e 780
40d98b49 781 PUTBACK;
f0a78170 782 {
a79b25b7
VP		 783 STRLEN len = 0;
784 const char *d = NULL;
785 int mode;
786 if (discp)
787 d = SvPV_const(discp, len);
788 mode = mode_from_discipline(d, len);
f0a78170
NC		 789 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
790 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
791 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
792 SPAGAIN;
793 RETPUSHUNDEF;
794 }
795 }
796 SPAGAIN;
797 RETPUSHYES;
798 }
799 else {
800 SPAGAIN;
801 RETPUSHUNDEF;
38af81ff 802 }
40d98b49 803 }
a0d0e21e
LW		 804}
805
806PP(pp_tie)
807{
27da23d5 808 dVAR; dSP; dMARK;
a0d0e21e 809 HV* stash;
07822e36 810 GV *gv = NULL;
a0d0e21e 811 SV *sv;
1df70142 812 const I32 markoff = MARK - PL_stack_base;
e1ec3a88 813 const char *methname;
14befaf4 814 int how = PERL_MAGIC_tied;
e336de0d 815 U32 items;
c4420975 816 SV *varsv = *++MARK;
a0d0e21e 817
6b05c17a
NIS		 818 switch(SvTYPE(varsv)) {
819 case SVt_PVHV:
820 methname = "TIEHASH";
85fbaab2 821 HvEITER_set(MUTABLE_HV(varsv), 0);
6b05c17a
NIS		 822 break;
823 case SVt_PVAV:
824 methname = "TIEARRAY";
825 break;
826 case SVt_PVGV:
13be902c 827 case SVt_PVLV:
7850f4d6 828 if (isGV_with_GP(varsv)) {
7c7df812
FC		 829 if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
830 deprecate("tie on a handle without *");
831 GvFLAGS(varsv) |= GVf_TIEWARNED;
832 }
6e592b3a
BM		 833 methname = "TIEHANDLE";
834 how = PERL_MAGIC_tiedscalar;
835 /* For tied filehandles, we apply tiedscalar magic to the IO
836 slot of the GP rather than the GV itself. AMS 20010812 */
837 if (!GvIOp(varsv))
838 GvIOp(varsv) = newIO();
ad64d0ec 839 varsv = MUTABLE_SV(GvIOp(varsv));
6e592b3a
BM		 840 break;
841 }
842 /* FALL THROUGH */
6b05c17a
NIS		 843 default:
844 methname = "TIESCALAR";
14befaf4 845 how = PERL_MAGIC_tiedscalar;
6b05c17a
NIS		 846 break;
847 }
e336de0d 848 items = SP - MARK++;
a91d1d42 849 if (sv_isobject(*MARK)) { /* Calls GET magic. */
d343c3ef 850 ENTER_with_name("call_TIE");
e788e7d3 851 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 852 PUSHMARK(SP);
eb160463 853 EXTEND(SP,(I32)items);
e336de0d
GS		 854 while (items--)
855 PUSHs(*MARK++);
856 PUTBACK;
864dbfa3 857 call_method(methname, G_SCALAR);
301e8125 858 }
6b05c17a 859 else {
086d2913
NC		 860 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
861 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
862 * wrong error message, and worse case, supreme action at a distance.
863 * (Sorry obfuscation writers. You're not going to be given this one.)
6b05c17a 864 */
a91d1d42
VP		 865 STRLEN len;
866 const char *name = SvPV_nomg_const(*MARK, len);
867 stash = gv_stashpvn(name, len, 0);
6b05c17a 868 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
35c1215d 869 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
a91d1d42 870 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
6b05c17a 871 }
d343c3ef 872 ENTER_with_name("call_TIE");
e788e7d3 873 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 874 PUSHMARK(SP);
eb160463 875 EXTEND(SP,(I32)items);
e336de0d
GS		 876 while (items--)
877 PUSHs(*MARK++);
878 PUTBACK;
ad64d0ec 879 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
6b05c17a 880 }
a0d0e21e
LW		 881 SPAGAIN;
882
883 sv = TOPs;
d3acc0f7 884 POPSTACK;
a0d0e21e 885 if (sv_isobject(sv)) {
33c27489 886 sv_unmagic(varsv, how);
ae21d580 887 /* Croak if a self-tie on an aggregate is attempted. */
b881518d 888 if (varsv == SvRV(sv) &&
d87ebaca
YST		 889 (SvTYPE(varsv) == SVt_PVAV ||
890 SvTYPE(varsv) == SVt_PVHV))
ae21d580
JH		 891 Perl_croak(aTHX_
892 "Self-ties of arrays and hashes are not supported");
a0714e2c 893 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
a0d0e21e 894 }
d343c3ef 895 LEAVE_with_name("call_TIE");
3280af22 896 SP = PL_stack_base + markoff;
a0d0e21e
LW		 897 PUSHs(sv);
898 RETURN;
899}
900
901PP(pp_untie)
902{
27da23d5 903 dVAR; dSP;
5b468f54 904 MAGIC *mg;
33c27489 905 SV *sv = POPs;
1df70142 906 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 907 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
55497cff 908
7c7df812
FC		 909 if (isGV_with_GP(sv)) {
910 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
911 deprecate("untie on a handle without *");
912 GvFLAGS(sv) |= GVf_TIEWARNED;
913 }
914 if (!(sv = MUTABLE_SV(GvIOp(sv))))
5b468f54 915 RETPUSHYES;
7c7df812 916 }
5b468f54 917
65eba18f 918 if ((mg = SvTIED_mg(sv, how))) {
1b6737cc 919 SV * const obj = SvRV(SvTIED_obj(sv, mg));
fa2b88e0 920 if (obj) {
c4420975 921 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
0bd48802 922 CV *cv;
c4420975 923 if (gv && isGV(gv) && (cv = GvCV(gv))) {
fa2b88e0 924 PUSHMARK(SP);
c33ef3ac 925 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
6e449a3a 926 mXPUSHi(SvREFCNT(obj) - 1);
fa2b88e0 927 PUTBACK;
d343c3ef 928 ENTER_with_name("call_UNTIE");
ad64d0ec 929 call_sv(MUTABLE_SV(cv), G_VOID);
d343c3ef 930 LEAVE_with_name("call_UNTIE");
fa2b88e0
JS		 931 SPAGAIN;
932 }
a2a5de95
NC		 933 else if (mg && SvREFCNT(obj) > 1) {
934 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
935 "untie attempted while %"UVuf" inner references still exist",
936 (UV)SvREFCNT(obj) - 1 ) ;
c4420975 937 }
cbdc8872 938 }
939 }
38193a09 940 sv_unmagic(sv, how) ;
55497cff 941 RETPUSHYES;
a0d0e21e
LW		 942}
943
c07a80fd 944PP(pp_tied)
945{
97aff369 946 dVAR;
39644a26 947 dSP;
1b6737cc 948 const MAGIC *mg;
33c27489 949 SV *sv = POPs;
1df70142 950 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 951 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
5b468f54 952
7c7df812
FC		 953 if (isGV_with_GP(sv)) {
954 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
955 deprecate("tied on a handle without *");
956 GvFLAGS(sv) |= GVf_TIEWARNED;
957 }
958 if (!(sv = MUTABLE_SV(GvIOp(sv))))
5b468f54 959 RETPUSHUNDEF;
7c7df812 960 }
c07a80fd 961
155aba94 962 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS		 963 SV *osv = SvTIED_obj(sv, mg);
964 if (osv == mg->mg_obj)
965 osv = sv_mortalcopy(osv);
966 PUSHs(osv);
967 RETURN;
c07a80fd 968 }
c07a80fd 969 RETPUSHUNDEF;
970}
971
a0d0e21e
LW		 972PP(pp_dbmopen)
973{
27da23d5 974 dVAR; dSP;
a0d0e21e
LW		 975 dPOPPOPssrl;
976 HV* stash;
07822e36 977 GV *gv = NULL;
a0d0e21e 978
85fbaab2 979 HV * const hv = MUTABLE_HV(POPs);
84bafc02 980 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
da51bb9b 981 stash = gv_stashsv(sv, 0);
8ebc5c01 982 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 983 PUTBACK;
864dbfa3 984 require_pv("AnyDBM_File.pm");
a0d0e21e 985 SPAGAIN;
eff494dd 986 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 987 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 988 }
989
57d3b86d 990 ENTER;
924508f0 991 PUSHMARK(SP);
6b05c17a 992
924508f0 993 EXTEND(SP, 5);
a0d0e21e
LW		 994 PUSHs(sv);
995 PUSHs(left);
996 if (SvIV(right))
6e449a3a 997 mPUSHu(O_RDWR|O_CREAT);
a0d0e21e 998 else
6e449a3a 999 mPUSHu(O_RDWR);
a0d0e21e 1000 PUSHs(right);
57d3b86d 1001 PUTBACK;
ad64d0ec 1002 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW		 1003 SPAGAIN;
1004
1005 if (!sv_isobject(TOPs)) {
924508f0
GS		 1006 SP--;
1007 PUSHMARK(SP);
a0d0e21e
LW		 1008 PUSHs(sv);
1009 PUSHs(left);
6e449a3a 1010 mPUSHu(O_RDONLY);
a0d0e21e 1011 PUSHs(right);
a0d0e21e 1012 PUTBACK;
ad64d0ec 1013 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW		 1014 SPAGAIN;
1015 }
1016
6b05c17a 1017 if (sv_isobject(TOPs)) {
ad64d0ec
NC		 1018 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1019 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
6b05c17a 1020 }
a0d0e21e
LW		 1021 LEAVE;
1022 RETURN;
1023}
1024
a0d0e21e
LW		 1025PP(pp_sselect)
1026{
a0d0e21e 1027#ifdef HAS_SELECT
97aff369 1028 dVAR; dSP; dTARGET;
a0d0e21e
LW		 1029 register I32 i;
1030 register I32 j;
1031 register char *s;
1032 register SV *sv;
65202027 1033 NV value;
a0d0e21e
LW		 1034 I32 maxlen = 0;
1035 I32 nfound;
1036 struct timeval timebuf;
1037 struct timeval *tbuf = &timebuf;
1038 I32 growsize;
1039 char *fd_sets[4];
1040#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1041 I32 masksize;
1042 I32 offset;
1043 I32 k;
1044
1045# if BYTEORDER & 0xf0000
1046# define ORDERBYTE (0x88888888 - BYTEORDER)
1047# else
1048# define ORDERBYTE (0x4444 - BYTEORDER)
1049# endif
1050
1051#endif
1052
1053 SP -= 4;
1054 for (i = 1; i <= 3; i++) {
c4420975 1055 SV * const sv = SP[i];
15547071
GA		 1056 if (!SvOK(sv))
1057 continue;
1058 if (SvREADONLY(sv)) {
729c079f
NC		 1059 if (SvIsCOW(sv))
1060 sv_force_normal_flags(sv, 0);
15547071 1061 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
6ad8f254 1062 Perl_croak_no_modify(aTHX);
729c079f 1063 }
4ef2275c 1064 if (!SvPOK(sv)) {
a2a5de95 1065 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
4ef2275c
GA		 1066 SvPV_force_nolen(sv); /* force string conversion */
1067 }
729c079f 1068 j = SvCUR(sv);
a0d0e21e
LW		 1069 if (maxlen < j)
1070 maxlen = j;
1071 }
1072
5ff3f7a4 1073/* little endians can use vecs directly */
e366b469 1074#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
5ff3f7a4 1075# ifdef NFDBITS
a0d0e21e 1076
5ff3f7a4
GS		 1077# ifndef NBBY
1078# define NBBY 8
1079# endif
a0d0e21e
LW		 1080
1081 masksize = NFDBITS / NBBY;
5ff3f7a4 1082# else
a0d0e21e 1083 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 1084# endif
a0d0e21e
LW		 1085 Zero(&fd_sets[0], 4, char*);
1086#endif
1087
ad517f75
MHM		 1088# if SELECT_MIN_BITS == 1
1089 growsize = sizeof(fd_set);
1090# else
1091# if defined(__GLIBC__) && defined(__FD_SETSIZE)
1092# undef SELECT_MIN_BITS
1093# define SELECT_MIN_BITS __FD_SETSIZE
1094# endif
e366b469
PG		 1095 /* If SELECT_MIN_BITS is greater than one we most probably will want
1096 * to align the sizes with SELECT_MIN_BITS/8 because for example
1097 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1098 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1099 * on (sets/tests/clears bits) is 32 bits. */
1100 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
e366b469
PG		 1101# endif
1102
a0d0e21e
LW		 1103 sv = SP[4];
1104 if (SvOK(sv)) {
1105 value = SvNV(sv);
1106 if (value < 0.0)
1107 value = 0.0;
1108 timebuf.tv_sec = (long)value;
65202027 1109 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 1110 timebuf.tv_usec = (long)(value * 1000000.0);
1111 }
1112 else
4608196e 1113 tbuf = NULL;
a0d0e21e
LW		 1114
1115 for (i = 1; i <= 3; i++) {
1116 sv = SP[i];
15547071 1117 if (!SvOK(sv) || SvCUR(sv) == 0) {
a0d0e21e
LW		 1118 fd_sets[i] = 0;
1119 continue;
1120 }
4ef2275c 1121 assert(SvPOK(sv));
a0d0e21e
LW		 1122 j = SvLEN(sv);
1123 if (j < growsize) {
1124 Sv_Grow(sv, growsize);
a0d0e21e 1125 }
c07a80fd 1126 j = SvCUR(sv);
1127 s = SvPVX(sv) + j;
1128 while (++j <= growsize) {
1129 *s++ = '\0';
1130 }
1131
a0d0e21e
LW		 1132#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1133 s = SvPVX(sv);
a02a5408 1134 Newx(fd_sets[i], growsize, char);
a0d0e21e
LW		 1135 for (offset = 0; offset < growsize; offset += masksize) {
1136 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1137 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1138 }
1139#else
1140 fd_sets[i] = SvPVX(sv);
1141#endif
1142 }
1143
dc4c69d9
JH		 1144#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1145 /* Can't make just the (void*) conditional because that would be
1146 * cpp #if within cpp macro, and not all compilers like that. */
1147 nfound = PerlSock_select(
1148 maxlen * 8,
1149 (Select_fd_set_t) fd_sets[1],
1150 (Select_fd_set_t) fd_sets[2],
1151 (Select_fd_set_t) fd_sets[3],
1152 (void*) tbuf); /* Workaround for compiler bug. */
1153#else
6ad3d225 1154 nfound = PerlSock_select(
a0d0e21e
LW		 1155 maxlen * 8,
1156 (Select_fd_set_t) fd_sets[1],
1157 (Select_fd_set_t) fd_sets[2],
1158 (Select_fd_set_t) fd_sets[3],
1159 tbuf);
dc4c69d9 1160#endif
a0d0e21e
LW		 1161 for (i = 1; i <= 3; i++) {
1162 if (fd_sets[i]) {
1163 sv = SP[i];
1164#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1165 s = SvPVX(sv);
1166 for (offset = 0; offset < growsize; offset += masksize) {
1167 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1168 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1169 }
1170 Safefree(fd_sets[i]);
1171#endif
1172 SvSETMAGIC(sv);
1173 }
1174 }
1175
4189264e 1176 PUSHi(nfound);
a0d0e21e 1177 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1178 value = (NV)(timebuf.tv_sec) +
1179 (NV)(timebuf.tv_usec) / 1000000.0;
6e449a3a 1180 mPUSHn(value);
a0d0e21e
LW		 1181 }
1182 RETURN;
1183#else
cea2e8a9 1184 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1185#endif
1186}
1187
8226a3d7
NC		 1188/*
1189=for apidoc setdefout
1190
1191Sets PL_defoutgv, the default file handle for output, to the passed in
1192typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1193count of the passed in typeglob is increased by one, and the reference count
1194of the typeglob that PL_defoutgv points to is decreased by one.
1195
1196=cut
1197*/
1198
4633a7c4 1199void
864dbfa3 1200Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1201{
97aff369 1202 dVAR;
b37c2d43 1203 SvREFCNT_inc_simple_void(gv);
ef8d46e8 1204 SvREFCNT_dec(PL_defoutgv);
3280af22 1205 PL_defoutgv = gv;
4633a7c4
LW		 1206}
1207
a0d0e21e
LW		 1208PP(pp_select)
1209{
97aff369 1210 dVAR; dSP; dTARGET;
4633a7c4 1211 HV *hv;
159b6efe 1212 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
099be4f1 1213 GV * egv = GvEGVx(PL_defoutgv);
4633a7c4 1214
4633a7c4 1215 if (!egv)
3280af22 1216 egv = PL_defoutgv;
099be4f1 1217 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
4633a7c4 1218 if (! hv)
3280af22 1219 XPUSHs(&PL_sv_undef);
4633a7c4 1220 else {
c4420975 1221 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1222 if (gvp && *gvp == egv) {
bd61b366 1223 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
f86702cc 1224 XPUSHTARG;
1225 }
1226 else {
ad64d0ec 1227 mXPUSHs(newRV(MUTABLE_SV(egv)));
f86702cc 1228 }
4633a7c4
LW		 1229 }
1230
1231 if (newdefout) {
ded8aa31
GS		 1232 if (!GvIO(newdefout))
1233 gv_IOadd(newdefout);
4633a7c4
LW		 1234 setdefout(newdefout);
1235 }
1236
a0d0e21e
LW		 1237 RETURN;
1238}
1239
1240PP(pp_getc)
1241{
27da23d5 1242 dVAR; dSP; dTARGET;
90133b69 1243 IO *io = NULL;
159b6efe 1244 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
2ae324a7 1245
ac3697cd
NC		 1246 if (MAXARG == 0)
1247 EXTEND(SP, 1);
1248
a79db61d 1249 if (gv && (io = GvIO(gv))) {
ad64d0ec 1250 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1251 if (mg) {
0240605e 1252 const U32 gimme = GIMME_V;
f4adce6b 1253 S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
0240605e
NC		 1254 if (gimme == G_SCALAR) {
1255 SPAGAIN;
a79db61d 1256 SvSetMagicSV_nosteal(TARG, TOPs);
0240605e
NC		 1257 }
1258 return NORMAL;
a79db61d 1259 }
2ae324a7 1260 }
90133b69 1261 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
041457d9
DM		 1262 if ((!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
1263 && ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 1264 report_evil_fh(gv);
b5fe5ca2 1265 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1266 RETPUSHUNDEF;
90133b69 1267 }
bbce6d69 1268 TAINT;
76f68e9b 1269 sv_setpvs(TARG, " ");
9bc64814 1270 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
7d59b7e4
NIS		 1271 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1272 /* Find out how many bytes the char needs */
aa07b2f6 1273 Size_t len = UTF8SKIP(SvPVX_const(TARG));
7d59b7e4
NIS		 1274 if (len > 1) {
1275 SvGROW(TARG,len+1);
1276 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1277 SvCUR_set(TARG,1+len);
1278 }
1279 SvUTF8_on(TARG);
1280 }
a0d0e21e
LW		 1281 PUSHTARG;
1282 RETURN;
1283}
1284
76e3520e 1285STATIC OP *
cea2e8a9 1286S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1287{
27da23d5 1288 dVAR;
c09156bb 1289 register PERL_CONTEXT *cx;
f54cb97a 1290 const I32 gimme = GIMME_V;
a0d0e21e 1291
7918f24d
NC		 1292 PERL_ARGS_ASSERT_DOFORM;
1293
7b190374
NC		 1294 if (cv && CvCLONE(cv))
1295 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1296
a0d0e21e
LW		 1297 ENTER;
1298 SAVETMPS;
1299
146174a9 1300 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
10067d9a 1301 PUSHFORMAT(cx, retop);
fd617465
DM		 1302 SAVECOMPPAD();
1303 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
a0d0e21e 1304
4633a7c4 1305 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1306 return CvSTART(cv);
1307}
1308
1309PP(pp_enterwrite)
1310{
97aff369 1311 dVAR;
39644a26 1312 dSP;
a0d0e21e
LW		 1313 register GV *gv;
1314 register IO *io;
1315 GV *fgv;
07822e36
JH		 1316 CV *cv = NULL;
1317 SV *tmpsv = NULL;
a0d0e21e 1318
2addaaf3 1319 if (MAXARG == 0) {
3280af22 1320 gv = PL_defoutgv;
2addaaf3
NC		 1321 EXTEND(SP, 1);
1322 }
a0d0e21e 1323 else {
159b6efe 1324 gv = MUTABLE_GV(POPs);
a0d0e21e 1325 if (!gv)
3280af22 1326 gv = PL_defoutgv;
a0d0e21e 1327 }
a0d0e21e
LW		 1328 io = GvIO(gv);
1329 if (!io) {
1330 RETPUSHNO;
1331 }
1332 if (IoFMT_GV(io))
1333 fgv = IoFMT_GV(io);
1334 else
1335 fgv = gv;
1336
a79db61d
AL		 1337 if (!fgv)
1338 goto not_a_format_reference;
1339
a0d0e21e 1340 cv = GvFORM(fgv);
a0d0e21e 1341 if (!cv) {
f4a7049d 1342 const char *name;
10edeb5d 1343 tmpsv = sv_newmortal();
f4a7049d
NC		 1344 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1345 name = SvPV_nolen_const(tmpsv);
1346 if (name && *name)
1347 DIE(aTHX_ "Undefined format \"%s\" called", name);
a79db61d
AL		 1348
1349 not_a_format_reference:
cea2e8a9 1350 DIE(aTHX_ "Not a format reference");
a0d0e21e 1351 }
44a8e56a 1352 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1353 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1354}
1355
1356PP(pp_leavewrite)
1357{
27da23d5 1358 dVAR; dSP;
f9c764c5 1359 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1b6737cc 1360 register IO * const io = GvIOp(gv);
8b8cacda 1361 PerlIO *ofp;
760ac839 1362 PerlIO *fp;
8772537c
AL		 1363 SV **newsp;
1364 I32 gimme;
c09156bb 1365 register PERL_CONTEXT *cx;
8f89e5a9 1366 OP *retop;
a0d0e21e 1367
8b8cacda
B		 1368 if (!io || !(ofp = IoOFP(io)))
1369 goto forget_top;
1370
760ac839 1371 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1372 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
8b8cacda 1373
3280af22
NIS		 1374 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1375 PL_formtarget != PL_toptarget)
a0d0e21e 1376 {
4633a7c4
LW		 1377 GV *fgv;
1378 CV *cv;
a0d0e21e
LW		 1379 if (!IoTOP_GV(io)) {
1380 GV *topgv;
a0d0e21e
LW		 1381
1382 if (!IoTOP_NAME(io)) {
1b6737cc 1383 SV *topname;
a0d0e21e
LW		 1384 if (!IoFMT_NAME(io))
1385 IoFMT_NAME(io) = savepv(GvNAME(gv));
0bd0581c 1386 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
f776e3cd 1387 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
748a9306 1388 if ((topgv && GvFORM(topgv)) ||
fafc274c 1389 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
2e0de35c 1390 IoTOP_NAME(io) = savesvpv(topname);
a0d0e21e 1391 else
89529cee 1392 IoTOP_NAME(io) = savepvs("top");
a0d0e21e 1393 }
f776e3cd 1394 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
a0d0e21e 1395 if (!topgv || !GvFORM(topgv)) {
b929a54b 1396 IoLINES_LEFT(io) = IoPAGE_LEN(io);
a0d0e21e
LW		 1397 goto forget_top;
1398 }
1399 IoTOP_GV(io) = topgv;
1400 }
748a9306
LW		 1401 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1402 I32 lines = IoLINES_LEFT(io);
504618e9 1403 const char *s = SvPVX_const(PL_formtarget);
8e07c86e
AD		 1404 if (lines <= 0) /* Yow, header didn't even fit!!! */
1405 goto forget_top;
748a9306
LW		 1406 while (lines-- > 0) {
1407 s = strchr(s, '\n');
1408 if (!s)
1409 break;
1410 s++;
1411 }
1412 if (s) {
f54cb97a 1413 const STRLEN save = SvCUR(PL_formtarget);
aa07b2f6 1414 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
d75029d0
NIS		 1415 do_print(PL_formtarget, ofp);
1416 SvCUR_set(PL_formtarget, save);
3280af22
NIS		 1417 sv_chop(PL_formtarget, s);
1418 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1419 }
1420 }
a0d0e21e 1421 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
d75029d0 1422 do_print(PL_formfeed, ofp);
a0d0e21e
LW		 1423 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1424 IoPAGE(io)++;
3280af22 1425 PL_formtarget = PL_toptarget;
748a9306 1426 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1427 fgv = IoTOP_GV(io);
1428 if (!fgv)
cea2e8a9 1429 DIE(aTHX_ "bad top format reference");
4633a7c4 1430 cv = GvFORM(fgv);
1df70142
AL		 1431 if (!cv) {
1432 SV * const sv = sv_newmortal();
b464bac0 1433 const char *name;
bd61b366 1434 gv_efullname4(sv, fgv, NULL, FALSE);
e62f0680 1435 name = SvPV_nolen_const(sv);
2dd78f96 1436 if (name && *name)
0e528f24
JH		 1437 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1438 else
1439 DIE(aTHX_ "Undefined top format called");
4633a7c4 1440 }
0e528f24 1441 return doform(cv, gv, PL_op);
a0d0e21e
LW		 1442 }
1443
1444 forget_top:
3280af22 1445 POPBLOCK(cx,PL_curpm);
a0d0e21e 1446 POPFORMAT(cx);
8f89e5a9 1447 retop = cx->blk_sub.retop;
a0d0e21e
LW		 1448 LEAVE;
1449
1450 fp = IoOFP(io);
1451 if (!fp) {
7716c5c5
NC		 1452 if (IoIFP(io))
1453 report_wrongway_fh(gv, '<');
1454 else if (ckWARN(WARN_CLOSED))
1455 report_evil_fh(gv);
3280af22 1456 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1457 }
1458 else {
3280af22 1459 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
a2a5de95 1460 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
a0d0e21e 1461 }
d75029d0 1462 if (!do_print(PL_formtarget, fp))
3280af22 1463 PUSHs(&PL_sv_no);
a0d0e21e 1464 else {
3280af22
NIS		 1465 FmLINES(PL_formtarget) = 0;
1466 SvCUR_set(PL_formtarget, 0);
1467 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1468 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1469 (void)PerlIO_flush(fp);
3280af22 1470 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1471 }
1472 }
9cbac4c7 1473 /* bad_ofp: */
3280af22 1474 PL_formtarget = PL_bodytarget;
a0d0e21e 1475 PUTBACK;
29033a8a
SH		 1476 PERL_UNUSED_VAR(newsp);
1477 PERL_UNUSED_VAR(gimme);
8f89e5a9 1478 return retop;
a0d0e21e
LW		 1479}
1480
1481PP(pp_prtf)
1482{
27da23d5 1483 dVAR; dSP; dMARK; dORIGMARK;
a0d0e21e 1484 IO *io;
760ac839 1485 PerlIO *fp;
26db47c4 1486 SV *sv;
a0d0e21e 1487
159b6efe
NC		 1488 GV * const gv
1489 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
46fc3d4c 1490
a79db61d 1491 if (gv && (io = GvIO(gv))) {
ad64d0ec 1492 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d
AL		 1493 if (mg) {
1494 if (MARK == ORIGMARK) {
1495 MEXTEND(SP, 1);
1496 ++MARK;
1497 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1498 ++SP;
1499 }
1500 PUSHMARK(MARK - 1);
ad64d0ec 1501 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
a79db61d
AL		 1502 PUTBACK;
1503 ENTER;
1504 call_method("PRINTF", G_SCALAR);
1505 LEAVE;
5616b3e5 1506 return NORMAL;
a79db61d 1507 }
46fc3d4c 1508 }
1509
561b68a9 1510 sv = newSV(0);
a0d0e21e 1511 if (!(io = GvIO(gv))) {
2dd78f96 1512 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 1513 report_evil_fh(gv);
93189314 1514 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW		 1515 goto just_say_no;
1516 }
1517 else if (!(fp = IoOFP(io))) {
7716c5c5
NC		 1518 if (IoIFP(io))
1519 report_wrongway_fh(gv, '<');
1520 else if (ckWARN(WARN_CLOSED))
1521 report_evil_fh(gv);
93189314 1522 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW		 1523 goto just_say_no;
1524 }
1525 else {
20ee07fb
RGS		 1526 if (SvTAINTED(MARK[1]))
1527 TAINT_PROPER("printf");
a0d0e21e
LW		 1528 do_sprintf(sv, SP - MARK, MARK + 1);
1529 if (!do_print(sv, fp))
1530 goto just_say_no;
1531
1532 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1533 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1534 goto just_say_no;
1535 }
1536 SvREFCNT_dec(sv);
1537 SP = ORIGMARK;
3280af22 1538 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1539 RETURN;
1540
1541 just_say_no:
1542 SvREFCNT_dec(sv);
1543 SP = ORIGMARK;
3280af22 1544 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1545 RETURN;
1546}
1547
c07a80fd 1548PP(pp_sysopen)
1549{
97aff369 1550 dVAR;
39644a26 1551 dSP;
1df70142
AL		 1552 const int perm = (MAXARG > 3) ? POPi : 0666;
1553 const int mode = POPi;
1b6737cc 1554 SV * const sv = POPs;
159b6efe 1555 GV * const gv = MUTABLE_GV(POPs);
1b6737cc 1556 STRLEN len;
c07a80fd 1557
4592e6ca 1558 /* Need TIEHANDLE method ? */
1b6737cc 1559 const char * const tmps = SvPV_const(sv, len);
e62f0680 1560 /* FIXME? do_open should do const */
4608196e 1561 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
c07a80fd 1562 IoLINES(GvIOp(gv)) = 0;
3280af22 1563 PUSHs(&PL_sv_yes);
c07a80fd 1564 }
1565 else {
3280af22 1566 PUSHs(&PL_sv_undef);
c07a80fd 1567 }
1568 RETURN;
1569}
1570
a0d0e21e
LW		 1571PP(pp_sysread)
1572{
27da23d5 1573 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 1574 int offset;
a0d0e21e
LW		 1575 IO *io;
1576 char *buffer;
5b54f415 1577 SSize_t length;
eb5c063a 1578 SSize_t count;
1e422769 1579 Sock_size_t bufsize;
748a9306 1580 SV *bufsv;
a0d0e21e 1581 STRLEN blen;
eb5c063a 1582 int fp_utf8;
1dd30107
NC		 1583 int buffer_utf8;
1584 SV *read_target;
eb5c063a
NIS		 1585 Size_t got = 0;
1586 Size_t wanted;
1d636c13 1587 bool charstart = FALSE;
87330c3c
JH		 1588 STRLEN charskip = 0;
1589 STRLEN skip = 0;
a0d0e21e 1590
159b6efe 1591 GV * const gv = MUTABLE_GV(*++MARK);
5b468f54 1592 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1b6737cc 1593 && gv && (io = GvIO(gv)) )
137443ea 1594 {
ad64d0ec 1595 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1b6737cc 1596 if (mg) {
1b6737cc 1597 PUSHMARK(MARK-1);
ad64d0ec 1598 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1b6737cc
AL		 1599 ENTER;
1600 call_method("READ", G_SCALAR);
1601 LEAVE;
5616b3e5 1602 return NORMAL;
1b6737cc 1603 }
2ae324a7 1604 }
1605
a0d0e21e
LW		 1606 if (!gv)
1607 goto say_undef;
748a9306 1608 bufsv = *++MARK;
ff68c719 1609 if (! SvOK(bufsv))
76f68e9b 1610 sv_setpvs(bufsv, "");
a0d0e21e 1611 length = SvIVx(*++MARK);
748a9306 1612 SETERRNO(0,0);
a0d0e21e
LW		 1613 if (MARK < SP)
1614 offset = SvIVx(*++MARK);
1615 else
1616 offset = 0;
1617 io = GvIO(gv);
b5fe5ca2
SR		 1618 if (!io || !IoIFP(io)) {
1619 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 1620 report_evil_fh(gv);
b5fe5ca2 1621 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1622 goto say_undef;
b5fe5ca2 1623 }
0064a8a9 1624 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
7d59b7e4 1625 buffer = SvPVutf8_force(bufsv, blen);
1e54db1a 1626 /* UTF-8 may not have been set if they are all low bytes */
eb5c063a 1627 SvUTF8_on(bufsv);
9b9d7ce8 1628 buffer_utf8 = 0;
7d59b7e4
NIS		 1629 }
1630 else {
1631 buffer = SvPV_force(bufsv, blen);
1dd30107 1632 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
7d59b7e4
NIS		 1633 }
1634 if (length < 0)
1635 DIE(aTHX_ "Negative length");
eb5c063a 1636 wanted = length;
7d59b7e4 1637
d0965105
JH		 1638 charstart = TRUE;
1639 charskip = 0;
87330c3c 1640 skip = 0;
d0965105 1641
a0d0e21e 1642#ifdef HAS_SOCKET
533c011a 1643 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1644 char namebuf[MAXPATHLEN];
17a8c7ba 1645#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
490ab354
JH		 1646 bufsize = sizeof (struct sockaddr_in);
1647#else
46fc3d4c 1648 bufsize = sizeof namebuf;
490ab354 1649#endif
abf95952
IZ		 1650#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1651 if (bufsize >= 256)
1652 bufsize = 255;
1653#endif
eb160463 1654 buffer = SvGROW(bufsv, (STRLEN)(length+1));
bbce6d69 1655 /* 'offset' means 'flags' here */
eb5c063a 1656 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
10edeb5d 1657 (struct sockaddr *)namebuf, &bufsize);
eb5c063a 1658 if (count < 0)
a0d0e21e 1659 RETPUSHUNDEF;
8eb023a9
DM		 1660 /* MSG_TRUNC can give oversized count; quietly lose it */
1661 if (count > length)
1662 count = length;
4107cc59
OF		 1663#ifdef EPOC
1664 /* Bogus return without padding */
1665 bufsize = sizeof (struct sockaddr_in);
1666#endif
eb5c063a 1667 SvCUR_set(bufsv, count);
748a9306
LW		 1668 *SvEND(bufsv) = '\0';
1669 (void)SvPOK_only(bufsv);
eb5c063a
NIS		 1670 if (fp_utf8)
1671 SvUTF8_on(bufsv);
748a9306 1672 SvSETMAGIC(bufsv);
aac0dd9a 1673 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1674 if (!(IoFLAGS(io) & IOf_UNTAINT))
1675 SvTAINTED_on(bufsv);
a0d0e21e 1676 SP = ORIGMARK;
46fc3d4c 1677 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1678 PUSHs(TARG);
1679 RETURN;
1680 }
1681#else
911d147d 1682 if (PL_op->op_type == OP_RECV)
cea2e8a9 1683 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1684#endif
eb5c063a
NIS		 1685 if (DO_UTF8(bufsv)) {
1686 /* offset adjust in characters not bytes */
1687 blen = sv_len_utf8(bufsv);
7d59b7e4 1688 }
bbce6d69 1689 if (offset < 0) {
eb160463 1690 if (-offset > (int)blen)
cea2e8a9 1691 DIE(aTHX_ "Offset outside string");
bbce6d69 1692 offset += blen;
1693 }
eb5c063a
NIS		 1694 if (DO_UTF8(bufsv)) {
1695 /* convert offset-as-chars to offset-as-bytes */
6960c29a
CH		 1696 if (offset >= (int)blen)
1697 offset += SvCUR(bufsv) - blen;
1698 else
1699 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
eb5c063a
NIS		 1700 }
1701 more_bytes:
cd52b7b2 1702 bufsize = SvCUR(bufsv);
1dd30107
NC		 1703 /* Allocating length + offset + 1 isn't perfect in the case of reading
1704 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1705 unduly.
1706 (should be 2 * length + offset + 1, or possibly something longer if
1707 PL_encoding is true) */
eb160463 1708 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
27da23d5 1709 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
cd52b7b2 1710 Zero(buffer+bufsize, offset-bufsize, char);
1711 }
eb5c063a 1712 buffer = buffer + offset;
1dd30107
NC		 1713 if (!buffer_utf8) {
1714 read_target = bufsv;
1715 } else {
1716 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1717 concatenate it to the current buffer. */
1718
1719 /* Truncate the existing buffer to the start of where we will be
1720 reading to: */
1721 SvCUR_set(bufsv, offset);
1722
1723 read_target = sv_newmortal();
862a34c6 1724 SvUPGRADE(read_target, SVt_PV);
fe2774ed 1725 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1dd30107 1726 }
eb5c063a 1727
533c011a 1728 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1729#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1730 if (IoTYPE(io) == IoTYPE_SOCKET) {
eb5c063a
NIS		 1731 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1732 buffer, length, 0);
a7092146
GS		 1733 }
1734 else
1735#endif
1736 {
eb5c063a
NIS		 1737 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1738 buffer, length);
a7092146 1739 }
a0d0e21e
LW		 1740 }
1741 else
1742#ifdef HAS_SOCKET__bad_code_maybe
50952442 1743 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1744 char namebuf[MAXPATHLEN];
490ab354
JH		 1745#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1746 bufsize = sizeof (struct sockaddr_in);
1747#else
46fc3d4c 1748 bufsize = sizeof namebuf;
490ab354 1749#endif
eb5c063a 1750 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
46fc3d4c 1751 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1752 }
1753 else
1754#endif
3b02c43c 1755 {
eb5c063a
NIS		 1756 count = PerlIO_read(IoIFP(io), buffer, length);
1757 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1758 if (count == 0 && PerlIO_error(IoIFP(io)))
1759 count = -1;
3b02c43c 1760 }
eb5c063a 1761 if (count < 0) {
7716c5c5 1762 if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1763 report_wrongway_fh(gv, '>');
a0d0e21e 1764 goto say_undef;
af8c498a 1765 }
aa07b2f6 1766 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1dd30107
NC		 1767 *SvEND(read_target) = '\0';
1768 (void)SvPOK_only(read_target);
0064a8a9 1769 if (fp_utf8 && !IN_BYTES) {
eb5c063a 1770 /* Look at utf8 we got back and count the characters */
1df70142 1771 const char *bend = buffer + count;
eb5c063a 1772 while (buffer < bend) {
d0965105
JH		 1773 if (charstart) {
1774 skip = UTF8SKIP(buffer);
1775 charskip = 0;
1776 }
1777 if (buffer - charskip + skip > bend) {
eb5c063a
NIS		 1778 /* partial character - try for rest of it */
1779 length = skip - (bend-buffer);
aa07b2f6 1780 offset = bend - SvPVX_const(bufsv);
d0965105
JH		 1781 charstart = FALSE;
1782 charskip += count;
eb5c063a
NIS		 1783 goto more_bytes;
1784 }
1785 else {
1786 got++;
1787 buffer += skip;
d0965105
JH		 1788 charstart = TRUE;
1789 charskip = 0;
eb5c063a
NIS		 1790 }
1791 }
1792 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1793 provided amount read (count) was what was requested (length)
1794 */
1795 if (got < wanted && count == length) {
d0965105 1796 length = wanted - got;
aa07b2f6 1797 offset = bend - SvPVX_const(bufsv);
eb5c063a
NIS		 1798 goto more_bytes;
1799 }
1800 /* return value is character count */
1801 count = got;
1802 SvUTF8_on(bufsv);
1803 }
1dd30107
NC		 1804 else if (buffer_utf8) {
1805 /* Let svcatsv upgrade the bytes we read in to utf8.
1806 The buffer is a mortal so will be freed soon. */
1807 sv_catsv_nomg(bufsv, read_target);
1808 }
748a9306 1809 SvSETMAGIC(bufsv);
aac0dd9a 1810 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1811 if (!(IoFLAGS(io) & IOf_UNTAINT))
1812 SvTAINTED_on(bufsv);
a0d0e21e 1813 SP = ORIGMARK;
eb5c063a 1814 PUSHi(count);
a0d0e21e
LW		 1815 RETURN;
1816
1817 say_undef:
1818 SP = ORIGMARK;
1819 RETPUSHUNDEF;
1820}
1821
a0d0e21e
LW		 1822PP(pp_send)
1823{
27da23d5 1824 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 1825 IO *io;
748a9306 1826 SV *bufsv;
83003860 1827 const char *buffer;
8c99d73e 1828 SSize_t retval;
a0d0e21e 1829 STRLEN blen;
c9cb0f41 1830 STRLEN orig_blen_bytes;
64a1bc8e 1831 const int op_type = PL_op->op_type;
c9cb0f41
NC		 1832 bool doing_utf8;
1833 U8 *tmpbuf = NULL;
64a1bc8e 1834
159b6efe 1835 GV *const gv = MUTABLE_GV(*++MARK);
14befaf4 1836 if (PL_op->op_type == OP_SYSWRITE
a79db61d 1837 && gv && (io = GvIO(gv))) {
ad64d0ec 1838 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1839 if (mg) {
a79db61d 1840 if (MARK == SP - 1) {
c8834ab7
TC		 1841 SV *sv = *SP;
1842 mXPUSHi(sv_len(sv));
a79db61d
AL		 1843 PUTBACK;
1844 }
1845
1846 PUSHMARK(ORIGMARK);
ad64d0ec 1847 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
a79db61d
AL		 1848 ENTER;
1849 call_method("WRITE", G_SCALAR);
1850 LEAVE;
5616b3e5 1851 return NORMAL;
64a1bc8e 1852 }
1d603a67 1853 }
a0d0e21e
LW		 1854 if (!gv)
1855 goto say_undef;
64a1bc8e 1856
748a9306 1857 bufsv = *++MARK;
64a1bc8e 1858
748a9306 1859 SETERRNO(0,0);
a0d0e21e 1860 io = GvIO(gv);
cf167416 1861 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
8c99d73e 1862 retval = -1;
cf167416
RGS		 1863 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
1864 if (io && IoIFP(io))
a5390457 1865 report_wrongway_fh(gv, '<');
cf167416 1866 else
831e4cc3 1867 report_evil_fh(gv);
cf167416 1868 }
b5fe5ca2 1869 SETERRNO(EBADF,RMS_IFI);
7d59b7e4
NIS		 1870 goto say_undef;
1871 }
1872
c9cb0f41
NC		 1873 /* Do this first to trigger any overloading. */
1874 buffer = SvPV_const(bufsv, blen);
1875 orig_blen_bytes = blen;
1876 doing_utf8 = DO_UTF8(bufsv);
1877
7d59b7e4 1878 if (PerlIO_isutf8(IoIFP(io))) {
6aa2f6a7 1879 if (!SvUTF8(bufsv)) {
c9cb0f41
NC		 1880 /* We don't modify the original scalar. */
1881 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1882 buffer = (char *) tmpbuf;
1883 doing_utf8 = TRUE;
1884 }
a0d0e21e 1885 }
c9cb0f41
NC		 1886 else if (doing_utf8) {
1887 STRLEN tmplen = blen;
a79db61d 1888 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
c9cb0f41
NC		 1889 if (!doing_utf8) {
1890 tmpbuf = result;
1891 buffer = (char *) tmpbuf;
1892 blen = tmplen;
1893 }
1894 else {
1895 assert((char *)result == buffer);
1896 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1897 }
7d59b7e4
NIS		 1898 }
1899
64a1bc8e 1900 if (op_type == OP_SYSWRITE) {
c9cb0f41
NC		 1901 Size_t length = 0; /* This length is in characters. */
1902 STRLEN blen_chars;
7d59b7e4 1903 IV offset;
c9cb0f41
NC		 1904
1905 if (doing_utf8) {
1906 if (tmpbuf) {
1907 /* The SV is bytes, and we've had to upgrade it. */
1908 blen_chars = orig_blen_bytes;
1909 } else {
1910 /* The SV really is UTF-8. */
1911 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1912 /* Don't call sv_len_utf8 again because it will call magic
1913 or overloading a second time, and we might get back a
1914 different result. */
9a206dfd 1915 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
c9cb0f41
NC		 1916 } else {
1917 /* It's safe, and it may well be cached. */
1918 blen_chars = sv_len_utf8(bufsv);
1919 }
1920 }
1921 } else {
1922 blen_chars = blen;
1923 }
1924
1925 if (MARK >= SP) {
1926 length = blen_chars;
1927 } else {
1928#if Size_t_size > IVSIZE
1929 length = (Size_t)SvNVx(*++MARK);
1930#else
1931 length = (Size_t)SvIVx(*++MARK);
1932#endif
4b0c4b6f
NC		 1933 if ((SSize_t)length < 0) {
1934 Safefree(tmpbuf);
c9cb0f41 1935 DIE(aTHX_ "Negative length");
4b0c4b6f 1936 }
7d59b7e4 1937 }
c9cb0f41 1938
bbce6d69 1939 if (MARK < SP) {
a0d0e21e 1940 offset = SvIVx(*++MARK);
bbce6d69 1941 if (offset < 0) {
4b0c4b6f
NC		 1942 if (-offset > (IV)blen_chars) {
1943 Safefree(tmpbuf);
cea2e8a9 1944 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1945 }
c9cb0f41 1946 offset += blen_chars;
3c946528 1947 } else if (offset > (IV)blen_chars) {
4b0c4b6f 1948 Safefree(tmpbuf);
cea2e8a9 1949 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1950 }
bbce6d69 1951 } else
a0d0e21e 1952 offset = 0;
c9cb0f41
NC		 1953 if (length > blen_chars - offset)
1954 length = blen_chars - offset;
1955 if (doing_utf8) {
1956 /* Here we convert length from characters to bytes. */
1957 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1958 /* Either we had to convert the SV, or the SV is magical, or
1959 the SV has overloading, in which case we can't or mustn't
1960 or mustn't call it again. */
1961
1962 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1963 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1964 } else {
1965 /* It's a real UTF-8 SV, and it's not going to change under
1966 us. Take advantage of any cache. */
1967 I32 start = offset;
1968 I32 len_I32 = length;
1969
1970 /* Convert the start and end character positions to bytes.
1971 Remember that the second argument to sv_pos_u2b is relative
1972 to the first. */
1973 sv_pos_u2b(bufsv, &start, &len_I32);
1974
1975 buffer += start;
1976 length = len_I32;
1977 }
7d59b7e4
NIS		 1978 }
1979 else {
1980 buffer = buffer+offset;
1981 }
a7092146 1982#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1983 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1984 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1985 buffer, length, 0);
a7092146
GS		 1986 }
1987 else
1988#endif
1989 {
94e4c244 1990 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1991 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1992 buffer, length);
a7092146 1993 }
a0d0e21e
LW		 1994 }
1995#ifdef HAS_SOCKET
64a1bc8e
NC		 1996 else {
1997 const int flags = SvIVx(*++MARK);
1998 if (SP > MARK) {
1999 STRLEN mlen;
2000 char * const sockbuf = SvPVx(*++MARK, mlen);
2001 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2002 flags, (struct sockaddr *)sockbuf, mlen);
2003 }
2004 else {
2005 retval
2006 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2007 }
a0d0e21e 2008 }
a0d0e21e
LW		 2009#else
2010 else
cea2e8a9 2011 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 2012#endif
c9cb0f41 2013
8c99d73e 2014 if (retval < 0)
a0d0e21e
LW		 2015 goto say_undef;
2016 SP = ORIGMARK;
c9cb0f41 2017 if (doing_utf8)
f36eea10 2018 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
4b0c4b6f 2019
a79db61d 2020 Safefree(tmpbuf);
8c99d73e
GS		 2021#if Size_t_size > IVSIZE
2022 PUSHn(retval);
2023#else
2024 PUSHi(retval);
2025#endif
a0d0e21e
LW		 2026 RETURN;
2027
2028 say_undef:
a79db61d 2029 Safefree(tmpbuf);
a0d0e21e
LW		 2030 SP = ORIGMARK;
2031 RETPUSHUNDEF;
2032}
2033
a0d0e21e
LW		 2034PP(pp_eof)
2035{
27da23d5 2036 dVAR; dSP;
a0d0e21e 2037 GV *gv;
32e65323
CS		 2038 IO *io;
2039 MAGIC *mg;
bc0c81ca
NC		 2040 /*
2041 * in Perl 5.12 and later, the additional parameter is a bitmask:
2042 * 0 = eof
2043 * 1 = eof(FH)
2044 * 2 = eof() <- ARGV magic
2045 *
2046 * I'll rely on the compiler's trace flow analysis to decide whether to
2047 * actually assign this out here, or punt it into the only block where it is
2048 * used. Doing it out here is DRY on the condition logic.
2049 */
2050 unsigned int which;
a0d0e21e 2051
bc0c81ca 2052 if (MAXARG) {
32e65323 2053 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
bc0c81ca
NC		 2054 which = 1;
2055 }
b5f55170
NC		 2056 else {
2057 EXTEND(SP, 1);
2058
bc0c81ca 2059 if (PL_op->op_flags & OPf_SPECIAL) {
b5f55170 2060 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
bc0c81ca
NC		 2061 which = 2;
2062 }
2063 else {
b5f55170 2064 gv = PL_last_in_gv; /* eof */
bc0c81ca
NC		 2065 which = 0;
2066 }
b5f55170 2067 }
32e65323
CS		 2068
2069 if (!gv)
2070 RETPUSHNO;
2071
2072 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
74f0b550 2073 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
146174a9 2074 }
4592e6ca 2075
32e65323
CS		 2076 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2077 if (io && !IoIFP(io)) {
2078 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2079 IoLINES(io) = 0;
2080 IoFLAGS(io) &= ~IOf_START;
2081 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2082 if (GvSV(gv))
2083 sv_setpvs(GvSV(gv), "-");
2084 else
2085 GvSV(gv) = newSVpvs("-");
2086 SvSETMAGIC(GvSV(gv));
2087 }
2088 else if (!nextargv(gv))
2089 RETPUSHYES;
6136c704 2090 }
4592e6ca
NIS		 2091 }
2092
32e65323 2093 PUSHs(boolSV(do_eof(gv)));
a0d0e21e
LW		 2094 RETURN;
2095}
2096
2097PP(pp_tell)
2098{
27da23d5 2099 dVAR; dSP; dTARGET;
301e8125 2100 GV *gv;
5b468f54 2101 IO *io;
a0d0e21e 2102
c4420975 2103 if (MAXARG != 0)
159b6efe 2104 PL_last_in_gv = MUTABLE_GV(POPs);
ac3697cd
NC		 2105 else
2106 EXTEND(SP, 1);
c4420975 2107 gv = PL_last_in_gv;
4592e6ca 2108
a79db61d 2109 if (gv && (io = GvIO(gv))) {
ad64d0ec 2110 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2111 if (mg) {
ebc1fde6 2112 return tied_handle_method("TELL", SP, io, mg);
a79db61d 2113 }
4592e6ca 2114 }
f4817f32 2115 else if (!gv) {
f03173f2
RGS		 2116 if (!errno)
2117 SETERRNO(EBADF,RMS_IFI);
2118 PUSHi(-1);
2119 RETURN;
2120 }
4592e6ca 2121
146174a9
CB		 2122#if LSEEKSIZE > IVSIZE
2123 PUSHn( do_tell(gv) );
2124#else
a0d0e21e 2125 PUSHi( do_tell(gv) );
146174a9 2126#endif
a0d0e21e
LW		 2127 RETURN;
2128}
2129
137443ea 2130PP(pp_sysseek)
2131{
27da23d5 2132 dVAR; dSP;
1df70142 2133 const int whence = POPi;
146174a9 2134#if LSEEKSIZE > IVSIZE
7452cf6a 2135 const Off_t offset = (Off_t)SvNVx(POPs);
146174a9 2136#else
7452cf6a 2137 const Off_t offset = (Off_t)SvIVx(POPs);
146174a9 2138#endif
a0d0e21e 2139
159b6efe 2140 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
a79db61d 2141 IO *io;
4592e6ca 2142
a79db61d 2143 if (gv && (io = GvIO(gv))) {
ad64d0ec 2144 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2145 if (mg) {
cb50131a 2146#if LSEEKSIZE > IVSIZE
74f0b550 2147 SV *const offset_sv = newSVnv((NV) offset);
cb50131a 2148#else
74f0b550 2149 SV *const offset_sv = newSViv(offset);
cb50131a 2150#endif
bc0c81ca
NC		 2151
2152 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
74f0b550 2153 newSViv(whence));
a79db61d 2154 }
4592e6ca
NIS		 2155 }
2156
533c011a 2157 if (PL_op->op_type == OP_SEEK)
8903cb82 2158 PUSHs(boolSV(do_seek(gv, offset, whence)));
2159 else {
0bcc34c2 2160 const Off_t sought = do_sysseek(gv, offset, whence);
b448e4fe 2161 if (sought < 0)
146174a9
CB		 2162 PUSHs(&PL_sv_undef);
2163 else {
7452cf6a 2164 SV* const sv = sought ?
146174a9 2165#if LSEEKSIZE > IVSIZE
b448e4fe 2166 newSVnv((NV)sought)
146174a9 2167#else
b448e4fe 2168 newSViv(sought)
146174a9
CB		 2169#endif
2170 : newSVpvn(zero_but_true, ZBTLEN);
6e449a3a 2171 mPUSHs(sv);
146174a9 2172 }
8903cb82 2173 }
a0d0e21e
LW		 2174 RETURN;
2175}
2176
2177PP(pp_truncate)
2178{
97aff369 2179 dVAR;
39644a26 2180 dSP;
8c99d73e
GS		 2181 /* There seems to be no consensus on the length type of truncate()
2182 * and ftruncate(), both off_t and size_t have supporters. In
2183 * general one would think that when using large files, off_t is
2184 * at least as wide as size_t, so using an off_t should be okay. */
2185 /* XXX Configure probe for the length type of *truncate() needed XXX */
0bcc34c2 2186 Off_t len;
a0d0e21e 2187
25342a55 2188#if Off_t_size > IVSIZE
0bcc34c2 2189 len = (Off_t)POPn;
8c99d73e 2190#else
0bcc34c2 2191 len = (Off_t)POPi;
8c99d73e
GS		 2192#endif
2193 /* Checking for length < 0 is problematic as the type might or
301e8125 2194 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2195 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2196 SETERRNO(0,0);
d05c1ba0 2197 {
d05c1ba0
JH		 2198 int result = 1;
2199 GV *tmpgv;
090bf15b
SR		 2200 IO *io;
2201
d05c1ba0 2202 if (PL_op->op_flags & OPf_SPECIAL) {
f776e3cd 2203 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
d05c1ba0 2204
090bf15b
SR		 2205 do_ftruncate_gv:
2206 if (!GvIO(tmpgv))
2207 result = 0;
d05c1ba0 2208 else {
090bf15b
SR		 2209 PerlIO *fp;
2210 io = GvIOp(tmpgv);
2211 do_ftruncate_io:
2212 TAINT_PROPER("truncate");
2213 if (!(fp = IoIFP(io))) {
2214 result = 0;
2215 }
2216 else {
2217 PerlIO_flush(fp);
cbdc8872 2218#ifdef HAS_TRUNCATE
090bf15b 2219 if (ftruncate(PerlIO_fileno(fp), len) < 0)
301e8125 2220#else
090bf15b 2221 if (my_chsize(PerlIO_fileno(fp), len) < 0)
cbdc8872 2222#endif
090bf15b
SR		 2223 result = 0;
2224 }
d05c1ba0 2225 }
cbdc8872 2226 }
d05c1ba0 2227 else {
7452cf6a 2228 SV * const sv = POPs;
83003860 2229 const char *name;
7a5fd60d 2230
6e592b3a 2231 if (isGV_with_GP(sv)) {
159b6efe 2232 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
090bf15b 2233 goto do_ftruncate_gv;
d05c1ba0 2234 }
6e592b3a 2235 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
159b6efe 2236 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
090bf15b
SR		 2237 goto do_ftruncate_gv;
2238 }
2239 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2240 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
090bf15b 2241 goto do_ftruncate_io;
d05c1ba0 2242 }
1e422769 2243
83003860 2244 name = SvPV_nolen_const(sv);
d05c1ba0 2245 TAINT_PROPER("truncate");
cbdc8872 2246#ifdef HAS_TRUNCATE
d05c1ba0
JH		 2247 if (truncate(name, len) < 0)
2248 result = 0;
cbdc8872 2249#else
d05c1ba0 2250 {
7452cf6a 2251 const int tmpfd = PerlLIO_open(name, O_RDWR);
d05c1ba0 2252
7452cf6a 2253 if (tmpfd < 0)
cbdc8872 2254 result = 0;
d05c1ba0
JH		 2255 else {
2256 if (my_chsize(tmpfd, len) < 0)
2257 result = 0;
2258 PerlLIO_close(tmpfd);
2259 }
cbdc8872 2260 }
a0d0e21e 2261#endif
d05c1ba0 2262 }
a0d0e21e 2263
d05c1ba0
JH		 2264 if (result)
2265 RETPUSHYES;
2266 if (!errno)
93189314 2267 SETERRNO(EBADF,RMS_IFI);
d05c1ba0
JH		 2268 RETPUSHUNDEF;
2269 }
a0d0e21e
LW		 2270}
2271
a0d0e21e
LW		 2272PP(pp_ioctl)
2273{
97aff369 2274 dVAR; dSP; dTARGET;
7452cf6a 2275 SV * const argsv = POPs;
1df70142 2276 const unsigned int func = POPu;
e1ec3a88 2277 const int optype = PL_op->op_type;
159b6efe 2278 GV * const gv = MUTABLE_GV(POPs);
4608196e 2279 IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2280 char *s;
324aa91a 2281 IV retval;
a0d0e21e 2282
748a9306 2283 if (!io || !argsv || !IoIFP(io)) {
c289d2f7 2284 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 2285 report_evil_fh(gv);
93189314 2286 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
a0d0e21e
LW		 2287 RETPUSHUNDEF;
2288 }
2289
748a9306 2290 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2291 STRLEN len;
324aa91a 2292 STRLEN need;
748a9306 2293 s = SvPV_force(argsv, len);
324aa91a
HF		 2294 need = IOCPARM_LEN(func);
2295 if (len < need) {
2296 s = Sv_Grow(argsv, need + 1);
2297 SvCUR_set(argsv, need);
a0d0e21e
LW		 2298 }
2299
748a9306 2300 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 2301 }
2302 else {
748a9306 2303 retval = SvIV(argsv);
c529f79d 2304 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 2305 }
2306
ed4b2e6b 2307 TAINT_PROPER(PL_op_desc[optype]);
a0d0e21e
LW		 2308
2309 if (optype == OP_IOCTL)
2310#ifdef HAS_IOCTL
76e3520e 2311 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2312#else
cea2e8a9 2313 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 2314#endif
2315 else
c214f4ad
WB		 2316#ifndef HAS_FCNTL
2317 DIE(aTHX_ "fcntl is not implemented");
2318#else
55497cff 2319#if defined(OS2) && defined(__EMX__)
760ac839 2320 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2321#else
760ac839 2322 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2323#endif
6652bd42 2324#endif
a0d0e21e 2325
6652bd42 2326#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
748a9306
LW		 2327 if (SvPOK(argsv)) {
2328 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2329 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2330 OP_NAME(PL_op));
748a9306
LW		 2331 s[SvCUR(argsv)] = 0; /* put our null back */
2332 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2333 }
2334
2335 if (retval == -1)
2336 RETPUSHUNDEF;
2337 if (retval != 0) {
2338 PUSHi(retval);
2339 }
2340 else {
8903cb82 2341 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2342 }
4808266b 2343#endif
c214f4ad 2344 RETURN;
a0d0e21e
LW		 2345}
2346
2347PP(pp_flock)
2348{
9cad6237 2349#ifdef FLOCK
97aff369 2350 dVAR; dSP; dTARGET;
a0d0e21e 2351 I32 value;
bc37a18f 2352 IO *io = NULL;
760ac839 2353 PerlIO *fp;
7452cf6a 2354 const int argtype = POPi;
159b6efe 2355 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
16d20bd9 2356
bc37a18f
RG		 2357 if (gv && (io = GvIO(gv)))
2358 fp = IoIFP(io);
2359 else {
4608196e 2360 fp = NULL;
bc37a18f
RG		 2361 io = NULL;
2362 }
0bcc34c2 2363 /* XXX Looks to me like io is always NULL at this point */
a0d0e21e 2364 if (fp) {
68dc0745 2365 (void)PerlIO_flush(fp);
76e3520e 2366 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2367 }
cb50131a 2368 else {
bc37a18f 2369 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 2370 report_evil_fh(gv);
a0d0e21e 2371 value = 0;
93189314 2372 SETERRNO(EBADF,RMS_IFI);
cb50131a 2373 }
a0d0e21e
LW		 2374 PUSHi(value);
2375 RETURN;
2376#else
cea2e8a9 2377 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2378#endif
2379}
2380
2381/* Sockets. */
2382
2383PP(pp_socket)
2384{
a0d0e21e 2385#ifdef HAS_SOCKET
97aff369 2386 dVAR; dSP;
7452cf6a
AL		 2387 const int protocol = POPi;
2388 const int type = POPi;
2389 const int domain = POPi;
159b6efe 2390 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2391 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e
LW		 2392 int fd;
2393
c289d2f7
JH		 2394 if (!gv || !io) {
2395 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 2396 report_evil_fh(gv);
5ee74a84 2397 if (io && IoIFP(io))
c289d2f7 2398 do_close(gv, FALSE);
93189314 2399 SETERRNO(EBADF,LIB_INVARG);
a0d0e21e
LW		 2400 RETPUSHUNDEF;
2401 }
2402
57171420
BS		 2403 if (IoIFP(io))
2404 do_close(gv, FALSE);
2405
a0d0e21e 2406 TAINT_PROPER("socket");
6ad3d225 2407 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2408 if (fd < 0)
2409 RETPUSHUNDEF;
460c8493
IZ		 2410 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2411 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2412 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2413 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2414 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2415 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2416 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2417 RETPUSHUNDEF;
2418 }
8d2a6795
GS		 2419#if defined(HAS_FCNTL) && defined(F_SETFD)
2420 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2421#endif
a0d0e21e 2422
d5ff79b3
OF		 2423#ifdef EPOC
2424 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2425#endif
2426
a0d0e21e
LW		 2427 RETPUSHYES;
2428#else
cea2e8a9 2429 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2430#endif
2431}
2432
2433PP(pp_sockpair)
2434{
c95c94b1 2435#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
97aff369 2436 dVAR; dSP;
7452cf6a
AL		 2437 const int protocol = POPi;
2438 const int type = POPi;
2439 const int domain = POPi;
159b6efe
NC		 2440 GV * const gv2 = MUTABLE_GV(POPs);
2441 GV * const gv1 = MUTABLE_GV(POPs);
7452cf6a
AL		 2442 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2443 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
a0d0e21e
LW		 2444 int fd[2];
2445
c289d2f7
JH		 2446 if (!gv1 || !gv2 || !io1 || !io2) {
2447 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2448 if (!gv1 || !io1)
831e4cc3 2449 report_evil_fh(gv1);
c289d2f7 2450 if (!gv2 || !io2)
831e4cc3 2451 report_evil_fh(gv2);
c289d2f7 2452 }
c289d2f7 2453 }
a0d0e21e 2454
46d2cc54 2455 if (io1 && IoIFP(io1))
dc0d0a5f 2456 do_close(gv1, FALSE);
46d2cc54 2457 if (io2 && IoIFP(io2))
dc0d0a5f 2458 do_close(gv2, FALSE);
57171420 2459
46d2cc54
NC		 2460 if (!io1 || !io2)
2461 RETPUSHUNDEF;
2462
a0d0e21e 2463 TAINT_PROPER("socketpair");
6ad3d225 2464 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2465 RETPUSHUNDEF;
460c8493
IZ		 2466 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2467 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
50952442 2468 IoTYPE(io1) = IoTYPE_SOCKET;
460c8493
IZ		 2469 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2470 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
50952442 2471 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2472 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2473 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2474 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2475 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2476 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2477 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2478 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2479 RETPUSHUNDEF;
2480 }
8d2a6795
GS		 2481#if defined(HAS_FCNTL) && defined(F_SETFD)
2482 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2483 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2484#endif
a0d0e21e
LW		 2485
2486 RETPUSHYES;
2487#else
cea2e8a9 2488 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2489#endif
2490}
2491
2492PP(pp_bind)
2493{
a0d0e21e 2494#ifdef HAS_SOCKET
97aff369 2495 dVAR; dSP;
7452cf6a 2496 SV * const addrsv = POPs;
349d4f2f
NC		 2497 /* OK, so on what platform does bind modify addr? */
2498 const char *addr;
159b6efe 2499 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2500 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 2501 STRLEN len;
2502
2503 if (!io || !IoIFP(io))
2504 goto nuts;
2505
349d4f2f 2506 addr = SvPV_const(addrsv, len);
a0d0e21e 2507 TAINT_PROPER("bind");
a79db61d 2508 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2509 RETPUSHYES;
2510 else
2511 RETPUSHUNDEF;
2512
2513nuts:
599cee73 2514 if (ckWARN(WARN_CLOSED))
831e4cc3 2515 report_evil_fh(gv);
93189314 2516 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2517 RETPUSHUNDEF;
2518#else
cea2e8a9 2519 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2520#endif
2521}
2522
2523PP(pp_connect)
2524{
a0d0e21e 2525#ifdef HAS_SOCKET
97aff369 2526 dVAR; dSP;
7452cf6a 2527 SV * const addrsv = POPs;
159b6efe 2528 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2529 register IO * const io = GvIOn(gv);
349d4f2f 2530 const char *addr;
a0d0e21e
LW		 2531 STRLEN len;
2532
2533 if (!io || !IoIFP(io))
2534 goto nuts;
2535
349d4f2f 2536 addr = SvPV_const(addrsv, len);
a0d0e21e 2537 TAINT_PROPER("connect");
6ad3d225 2538 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2539 RETPUSHYES;
2540 else
2541 RETPUSHUNDEF;
2542
2543nuts:
599cee73 2544 if (ckWARN(WARN_CLOSED))
831e4cc3 2545 report_evil_fh(gv);
93189314 2546 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2547 RETPUSHUNDEF;
2548#else
cea2e8a9 2549 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2550#endif
2551}
2552
2553PP(pp_listen)
2554{
a0d0e21e 2555#ifdef HAS_SOCKET
97aff369 2556 dVAR; dSP;
7452cf6a 2557 const int backlog = POPi;
159b6efe 2558 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2559 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2560
c289d2f7 2561 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2562 goto nuts;
2563
6ad3d225 2564 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2565 RETPUSHYES;
2566 else
2567 RETPUSHUNDEF;
2568
2569nuts:
599cee73 2570 if (ckWARN(WARN_CLOSED))
831e4cc3 2571 report_evil_fh(gv);
93189314 2572 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2573 RETPUSHUNDEF;
2574#else
cea2e8a9 2575 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2576#endif
2577}
2578
2579PP(pp_accept)
2580{
a0d0e21e 2581#ifdef HAS_SOCKET
97aff369 2582 dVAR; dSP; dTARGET;
a0d0e21e
LW		 2583 register IO *nstio;
2584 register IO *gstio;
93d47a36
JH		 2585 char namebuf[MAXPATHLEN];
2586#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2587 Sock_size_t len = sizeof (struct sockaddr_in);
2588#else
2589 Sock_size_t len = sizeof namebuf;
2590#endif
159b6efe
NC		 2591 GV * const ggv = MUTABLE_GV(POPs);
2592 GV * const ngv = MUTABLE_GV(POPs);
a0d0e21e
LW		 2593 int fd;
2594
a0d0e21e
LW		 2595 if (!ngv)
2596 goto badexit;
2597 if (!ggv)
2598 goto nuts;
2599
2600 gstio = GvIO(ggv);
2601 if (!gstio || !IoIFP(gstio))
2602 goto nuts;
2603
2604 nstio = GvIOn(ngv);
93d47a36 2605 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
e294cc5d
JH		 2606#if defined(OEMVS)
2607 if (len == 0) {
2608 /* Some platforms indicate zero length when an AF_UNIX client is
2609 * not bound. Simulate a non-zero-length sockaddr structure in
2610 * this case. */
2611 namebuf[0] = 0; /* sun_len */
2612 namebuf[1] = AF_UNIX; /* sun_family */
2613 len = 2;
2614 }
2615#endif
2616
a0d0e21e
LW		 2617 if (fd < 0)
2618 goto badexit;
a70048fb
AB		 2619 if (IoIFP(nstio))
2620 do_close(ngv, FALSE);
460c8493
IZ		 2621 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2622 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2623 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2624 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2625 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2626 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2627 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2628 goto badexit;
2629 }
8d2a6795
GS		 2630#if defined(HAS_FCNTL) && defined(F_SETFD)
2631 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2632#endif
a0d0e21e 2633
ed79a026 2634#ifdef EPOC
93d47a36 2635 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
a9f1f6b0 2636 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026 2637#endif
381c1bae 2638#ifdef __SCO_VERSION__
93d47a36 2639 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
381c1bae 2640#endif
ed79a026 2641
93d47a36 2642 PUSHp(namebuf, len);
a0d0e21e
LW		 2643 RETURN;
2644
2645nuts:
599cee73 2646 if (ckWARN(WARN_CLOSED))
831e4cc3 2647 report_evil_fh(ggv);
93189314 2648 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2649
2650badexit:
2651 RETPUSHUNDEF;
2652
2653#else
cea2e8a9 2654 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2655#endif
2656}
2657
2658PP(pp_shutdown)
2659{
a0d0e21e 2660#ifdef HAS_SOCKET
97aff369 2661 dVAR; dSP; dTARGET;
7452cf6a 2662 const int how = POPi;
159b6efe 2663 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2664 register IO * const io = GvIOn(gv);
a0d0e21e
LW		 2665
2666 if (!io || !IoIFP(io))
2667 goto nuts;
2668
6ad3d225 2669 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2670 RETURN;
2671
2672nuts:
599cee73 2673 if (ckWARN(WARN_CLOSED))
831e4cc3 2674 report_evil_fh(gv);
93189314 2675 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2676 RETPUSHUNDEF;
2677#else
cea2e8a9 2678 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2679#endif
2680}
2681
a0d0e21e
LW		 2682PP(pp_ssockopt)
2683{
a0d0e21e 2684#ifdef HAS_SOCKET
97aff369 2685 dVAR; dSP;
7452cf6a 2686 const int optype = PL_op->op_type;
561b68a9 2687 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
7452cf6a
AL		 2688 const unsigned int optname = (unsigned int) POPi;
2689 const unsigned int lvl = (unsigned int) POPi;
159b6efe 2690 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2691 register IO * const io = GvIOn(gv);
a0d0e21e 2692 int fd;
1e422769 2693 Sock_size_t len;
a0d0e21e 2694
a0d0e21e
LW		 2695 if (!io || !IoIFP(io))
2696 goto nuts;
2697
760ac839 2698 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2699 switch (optype) {
2700 case OP_GSOCKOPT:
748a9306 2701 SvGROW(sv, 257);
a0d0e21e 2702 (void)SvPOK_only(sv);
748a9306
LW		 2703 SvCUR_set(sv,256);
2704 *SvEND(sv) ='\0';
1e422769 2705 len = SvCUR(sv);
6ad3d225 2706 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2707 goto nuts2;
1e422769 2708 SvCUR_set(sv, len);
748a9306 2709 *SvEND(sv) ='\0';
a0d0e21e
LW		 2710 PUSHs(sv);
2711 break;
2712 case OP_SSOCKOPT: {
1215b447
JH		 2713#if defined(__SYMBIAN32__)
2714# define SETSOCKOPT_OPTION_VALUE_T void *
2715#else
2716# define SETSOCKOPT_OPTION_VALUE_T const char *
2717#endif
2718 /* XXX TODO: We need to have a proper type (a Configure probe,
2719 * etc.) for what the C headers think of the third argument of
2720 * setsockopt(), the option_value read-only buffer: is it
2721 * a "char *", or a "void *", const or not. Some compilers
2722 * don't take kindly to e.g. assuming that "char *" implicitly
2723 * promotes to a "void *", or to explicitly promoting/demoting
2724 * consts to non/vice versa. The "const void *" is the SUS
2725 * definition, but that does not fly everywhere for the above
2726 * reasons. */
2727 SETSOCKOPT_OPTION_VALUE_T buf;
1e422769 2728 int aint;
2729 if (SvPOKp(sv)) {
2d8e6c8d 2730 STRLEN l;
1215b447 2731 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2d8e6c8d 2732 len = l;
1e422769 2733 }
56ee1660 2734 else {
a0d0e21e 2735 aint = (int)SvIV(sv);
1215b447 2736 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
a0d0e21e
LW		 2737 len = sizeof(int);
2738 }
6ad3d225 2739 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2740 goto nuts2;
3280af22 2741 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2742 }
2743 break;
2744 }
2745 RETURN;
2746
2747nuts:
599cee73 2748 if (ckWARN(WARN_CLOSED))
831e4cc3 2749 report_evil_fh(gv);
93189314 2750 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2751nuts2:
2752 RETPUSHUNDEF;
2753
2754#else
af51a00e 2755 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 2756#endif
2757}
2758
a0d0e21e
LW		 2759PP(pp_getpeername)
2760{
a0d0e21e 2761#ifdef HAS_SOCKET
97aff369 2762 dVAR; dSP;
7452cf6a 2763 const int optype = PL_op->op_type;
159b6efe 2764 GV * const gv = MUTABLE_GV(POPs);
7452cf6a
AL		 2765 register IO * const io = GvIOn(gv);
2766 Sock_size_t len;
a0d0e21e
LW		 2767 SV *sv;
2768 int fd;
a0d0e21e
LW		 2769
2770 if (!io || !IoIFP(io))
2771 goto nuts;
2772
561b68a9 2773 sv = sv_2mortal(newSV(257));
748a9306 2774 (void)SvPOK_only(sv);
1e422769 2775 len = 256;
2776 SvCUR_set(sv, len);
748a9306 2777 *SvEND(sv) ='\0';
760ac839 2778 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2779 switch (optype) {
2780 case OP_GETSOCKNAME:
6ad3d225 2781 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2782 goto nuts2;
2783 break;
2784 case OP_GETPEERNAME:
6ad3d225 2785 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2786 goto nuts2;
490ab354
JH		 2787#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2788 {
2789 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";
2790 /* If the call succeeded, make sure we don't have a zeroed port/addr */
349d4f2f 2791 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2fbb330f 2792 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
490ab354 2793 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2794 goto nuts2;
490ab354
JH		 2795 }
2796 }
2797#endif
a0d0e21e
LW		 2798 break;
2799 }
13826f2c
CS		 2800#ifdef BOGUS_GETNAME_RETURN
2801 /* Interactive Unix, getpeername() and getsockname()
2802 does not return valid namelen */
1e422769 2803 if (len == BOGUS_GETNAME_RETURN)
2804 len = sizeof(struct sockaddr);
13826f2c 2805#endif
1e422769 2806 SvCUR_set(sv, len);
748a9306 2807 *SvEND(sv) ='\0';
a0d0e21e
LW		 2808 PUSHs(sv);
2809 RETURN;
2810
2811nuts:
599cee73 2812 if (ckWARN(WARN_CLOSED))
831e4cc3 2813 report_evil_fh(gv);
93189314 2814 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW		 2815nuts2:
2816 RETPUSHUNDEF;
2817
2818#else
af51a00e 2819 DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
a0d0e21e
LW		 2820#endif
2821}
2822
2823/* Stat calls. */
2824
a0d0e21e
LW		 2825PP(pp_stat)
2826{
97aff369 2827 dVAR;
39644a26 2828 dSP;
10edeb5d 2829 GV *gv = NULL;
ad02613c 2830 IO *io;
54310121 2831 I32 gimme;
a0d0e21e
LW		 2832 I32 max = 13;
2833
533c011a 2834 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2835 gv = cGVOP_gv;
8a4e5b40 2836 if (PL_op->op_type == OP_LSTAT) {
5d3e98de 2837 if (gv != PL_defgv) {
5d329e6e 2838 do_fstat_warning_check:
a2a5de95
NC		 2839 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
2840 "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
5d3e98de 2841 } else if (PL_laststype != OP_LSTAT)
8a4e5b40 2842 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
8a4e5b40
DD		 2843 }
2844
748a9306 2845 do_fstat:
2dd78f96 2846 if (gv != PL_defgv) {
3280af22 2847 PL_laststype = OP_STAT;
2dd78f96 2848 PL_statgv = gv;
76f68e9b 2849 sv_setpvs(PL_statname, "");
5228a96c 2850 if(gv) {
ad02613c
SP		 2851 io = GvIO(gv);
2852 do_fstat_have_io:
5228a96c
SP		 2853 if (io) {
2854 if (IoIFP(io)) {
2855 PL_laststatval =
2856 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2857 } else if (IoDIRP(io)) {
5228a96c 2858 PL_laststatval =
3497a01f 2859 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
5228a96c
SP		 2860 } else {
2861 PL_laststatval = -1;
2862 }
2863 }
2864 }
2865 }
2866
9ddeeac9 2867 if (PL_laststatval < 0) {
2dd78f96 2868 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
831e4cc3 2869 report_evil_fh(gv);
a0d0e21e 2870 max = 0;
9ddeeac9 2871 }
a0d0e21e
LW		 2872 }
2873 else {
7452cf6a 2874 SV* const sv = POPs;
6e592b3a 2875 if (isGV_with_GP(sv)) {
159b6efe 2876 gv = MUTABLE_GV(sv);
748a9306 2877 goto do_fstat;
6e592b3a 2878 } else if(SvROK(sv) && isGV_with_GP(SvRV(sv))) {
159b6efe 2879 gv = MUTABLE_GV(SvRV(sv));
ad02613c
SP		 2880 if (PL_op->op_type == OP_LSTAT)
2881 goto do_fstat_warning_check;
2882 goto do_fstat;
2883 } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2884 io = MUTABLE_IO(SvRV(sv));
ad02613c
SP		 2885 if (PL_op->op_type == OP_LSTAT)
2886 goto do_fstat_warning_check;
2887 goto do_fstat_have_io;
2888 }
2889
0510663f 2890 sv_setpv(PL_statname, SvPV_nolen_const(sv));
a0714e2c 2891 PL_statgv = NULL;
533c011a
NIS		 2892 PL_laststype = PL_op->op_type;
2893 if (PL_op->op_type == OP_LSTAT)
0510663f 2894 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
a0d0e21e 2895 else
0510663f 2896 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
3280af22 2897 if (PL_laststatval < 0) {
0510663f 2898 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
9014280d 2899 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
a0d0e21e
LW		 2900 max = 0;
2901 }
2902 }
2903
54310121 2904 gimme = GIMME_V;
2905 if (gimme != G_ARRAY) {
2906 if (gimme != G_VOID)
2907 XPUSHs(boolSV(max));
2908 RETURN;
a0d0e21e
LW		 2909 }
2910 if (max) {
36477c24 2911 EXTEND(SP, max);
2912 EXTEND_MORTAL(max);
6e449a3a
MHM		 2913 mPUSHi(PL_statcache.st_dev);
2914 mPUSHi(PL_statcache.st_ino);
2915 mPUSHu(PL_statcache.st_mode);
2916 mPUSHu(PL_statcache.st_nlink);
146174a9 2917#if Uid_t_size > IVSIZE
6e449a3a 2918 mPUSHn(PL_statcache.st_uid);
146174a9 2919#else
23dcd6c8 2920# if Uid_t_sign <= 0
6e449a3a 2921 mPUSHi(PL_statcache.st_uid);
23dcd6c8 2922# else
6e449a3a 2923 mPUSHu(PL_statcache.st_uid);
23dcd6c8 2924# endif
146174a9 2925#endif
301e8125 2926#if Gid_t_size > IVSIZE
6e449a3a 2927 mPUSHn(PL_statcache.st_gid);
146174a9 2928#else
23dcd6c8 2929# if Gid_t_sign <= 0
6e449a3a 2930 mPUSHi(PL_statcache.st_gid);
23dcd6c8 2931# else
6e449a3a 2932 mPUSHu(PL_statcache.st_gid);
23dcd6c8 2933# endif
146174a9 2934#endif
cbdc8872 2935#ifdef USE_STAT_RDEV
6e449a3a 2936 mPUSHi(PL_statcache.st_rdev);
cbdc8872 2937#else
84bafc02 2938 PUSHs(newSVpvs_flags("", SVs_TEMP));
cbdc8872 2939#endif
146174a9 2940#if Off_t_size > IVSIZE
6e449a3a 2941 mPUSHn(PL_statcache.st_size);
146174a9 2942#else
6e449a3a 2943 mPUSHi(PL_statcache.st_size);
146174a9 2944#endif
cbdc8872 2945#ifdef BIG_TIME
6e449a3a
MHM		 2946 mPUSHn(PL_statcache.st_atime);
2947 mPUSHn(PL_statcache.st_mtime);
2948 mPUSHn(PL_statcache.st_ctime);
cbdc8872 2949#else
6e449a3a
MHM		 2950 mPUSHi(PL_statcache.st_atime);
2951 mPUSHi(PL_statcache.st_mtime);
2952 mPUSHi(PL_statcache.st_ctime);
cbdc8872 2953#endif
a0d0e21e 2954#ifdef USE_STAT_BLOCKS
6e449a3a
MHM		 2955 mPUSHu(PL_statcache.st_blksize);
2956 mPUSHu(PL_statcache.st_blocks);
a0d0e21e 2957#else
84bafc02
NC		 2958 PUSHs(newSVpvs_flags("", SVs_TEMP));
2959 PUSHs(newSVpvs_flags("", SVs_TEMP));
a0d0e21e
LW		 2960#endif
2961 }
2962 RETURN;
2963}
2964
6f1401dc
DM		 2965#define tryAMAGICftest_MG(chr) STMT_START { \
2966 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
2967 && S_try_amagic_ftest(aTHX_ chr)) \
2968 return NORMAL; \
2969 } STMT_END
2970
2971STATIC bool
2972S_try_amagic_ftest(pTHX_ char chr) {
2973 dVAR;
2974 dSP;
2975 SV* const arg = TOPs;
2976
2977 assert(chr != '?');
2978 SvGETMAGIC(arg);
2979
2980 if ((PL_op->op_flags & OPf_KIDS)
2981 && SvAMAGIC(TOPs))
2982 {
2983 const char tmpchr = chr;
2984 const OP *next;
2985 SV * const tmpsv = amagic_call(arg,
2986 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2987 ftest_amg, AMGf_unary);
2988
2989 if (!tmpsv)
2990 return FALSE;
2991
2992 SPAGAIN;
2993
2994 next = PL_op->op_next;
2995 if (next->op_type >= OP_FTRREAD &&
2996 next->op_type <= OP_FTBINARY &&
2997 next->op_private & OPpFT_STACKED
2998 ) {
2999 if (SvTRUE(tmpsv))
3000 /* leave the object alone */
3001 return TRUE;
3002 }
3003
3004 SETs(tmpsv);
3005 PUTBACK;
3006 return TRUE;
3007 }
3008 return FALSE;
3009}
3010
3011
fbb0b3b3
RGS		 3012/* This macro is used by the stacked filetest operators :
3013 * if the previous filetest failed, short-circuit and pass its value.
3014 * Else, discard it from the stack and continue. --rgs
3015 */
3016#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
d724f706 3017 if (!SvTRUE(TOPs)) { RETURN; } \
fbb0b3b3
RGS		 3018 else { (void)POPs; PUTBACK; } \
3019 }
3020
a0d0e21e
LW		 3021PP(pp_ftrread)
3022{
97aff369 3023 dVAR;
9cad6237 3024 I32 result;
af9e49b4
NC		 3025 /* Not const, because things tweak this below. Not bool, because there's
3026 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
3027#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3028 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
3029 /* Giving some sort of initial value silences compilers. */
3030# ifdef R_OK
3031 int access_mode = R_OK;
3032# else
3033 int access_mode = 0;
3034# endif
5ff3f7a4 3035#else
af9e49b4
NC		 3036 /* access_mode is never used, but leaving use_access in makes the
3037 conditional compiling below much clearer. */
3038 I32 use_access = 0;
5ff3f7a4 3039#endif
2dcac756 3040 Mode_t stat_mode = S_IRUSR;
a0d0e21e 3041
af9e49b4 3042 bool effective = FALSE;
07fe7c6a 3043 char opchar = '?';
2a3ff820 3044 dSP;
af9e49b4 3045
7fb13887
BM		 3046 switch (PL_op->op_type) {
3047 case OP_FTRREAD: opchar = 'R'; break;
3048 case OP_FTRWRITE: opchar = 'W'; break;
3049 case OP_FTREXEC: opchar = 'X'; break;
3050 case OP_FTEREAD: opchar = 'r'; break;
3051 case OP_FTEWRITE: opchar = 'w'; break;
3052 case OP_FTEEXEC: opchar = 'x'; break;
3053 }
6f1401dc 3054 tryAMAGICftest_MG(opchar);
7fb13887 3055
fbb0b3b3 3056 STACKED_FTEST_CHECK;
af9e49b4
NC		 3057
3058 switch (PL_op->op_type) {
3059 case OP_FTRREAD:
3060#if !(defined(HAS_ACCESS) && defined(R_OK))
3061 use_access = 0;
3062#endif
3063 break;
3064
3065 case OP_FTRWRITE:
5ff3f7a4 3066#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 3067 access_mode = W_OK;
5ff3f7a4 3068#else
af9e49b4 3069 use_access = 0;
5ff3f7a4 3070#endif
af9e49b4
NC		 3071 stat_mode = S_IWUSR;
3072 break;
a0d0e21e 3073
af9e49b4 3074 case OP_FTREXEC:
5ff3f7a4 3075#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 3076 access_mode = X_OK;
5ff3f7a4 3077#else
af9e49b4 3078 use_access = 0;
5ff3f7a4 3079#endif
af9e49b4
NC		 3080 stat_mode = S_IXUSR;
3081 break;
a0d0e21e 3082
af9e49b4 3083 case OP_FTEWRITE:
faee0e31 3084#ifdef PERL_EFF_ACCESS
af9e49b4 3085 access_mode = W_OK;
5ff3f7a4 3086#endif
af9e49b4 3087 stat_mode = S_IWUSR;
7fb13887 3088 /* fall through */
a0d0e21e 3089
af9e49b4
NC		 3090 case OP_FTEREAD:
3091#ifndef PERL_EFF_ACCESS
3092 use_access = 0;
3093#endif
3094 effective = TRUE;
3095 break;
3096
af9e49b4 3097 case OP_FTEEXEC:
faee0e31 3098#ifdef PERL_EFF_ACCESS
b376053d 3099 access_mode = X_OK;
5ff3f7a4 3100#else
af9e49b4 3101 use_access = 0;
5ff3f7a4 3102#endif
af9e49b4
NC		 3103 stat_mode = S_IXUSR;
3104 effective = TRUE;
3105 break;
3106 }
a0d0e21e 3107
af9e49b4
NC		 3108 if (use_access) {
3109#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2c2f35ab 3110 const char *name = POPpx;
af9e49b4
NC		 3111 if (effective) {
3112# ifdef PERL_EFF_ACCESS
3113 result = PERL_EFF_ACCESS(name, access_mode);
3114# else
3115 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3116 OP_NAME(PL_op));
3117# endif
3118 }
3119 else {
3120# ifdef HAS_ACCESS
3121 result = access(name, access_mode);
3122# else
3123 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3124# endif
3125 }
5ff3f7a4
GS		 3126 if (result == 0)
3127 RETPUSHYES;
3128 if (result < 0)
3129 RETPUSHUNDEF;
3130 RETPUSHNO;
af9e49b4 3131#endif
22865c03 3132 }
af9e49b4 3133
40c852de 3134 result = my_stat_flags(0);
22865c03 3135 SPAGAIN;
a0d0e21e
LW		 3136 if (result < 0)
3137 RETPUSHUNDEF;
af9e49b4 3138 if (cando(stat_mode, effective, &PL_statcache))
a0d0e21e
LW		 3139 RETPUSHYES;
3140 RETPUSHNO;
3141}
3142
3143PP(pp_ftis)
3144{
97aff369 3145 dVAR;
fbb0b3b3 3146 I32 result;
d7f0a2f4 3147 const int op_type = PL_op->op_type;
07fe7c6a 3148 char opchar = '?';
2a3ff820 3149 dSP;
07fe7c6a
BM		 3150
3151 switch (op_type) {
3152 case OP_FTIS: opchar = 'e'; break;
3153 case OP_FTSIZE: opchar = 's'; break;
3154 case OP_FTMTIME: opchar = 'M'; break;
3155 case OP_FTCTIME: opchar = 'C'; break;
3156 case OP_FTATIME: opchar = 'A'; break;
3157 }
6f1401dc 3158 tryAMAGICftest_MG(opchar);
07fe7c6a 3159
fbb0b3b3 3160 STACKED_FTEST_CHECK;
7fb13887 3161
40c852de 3162 result = my_stat_flags(0);
fbb0b3b3 3163 SPAGAIN;
a0d0e21e
LW		 3164 if (result < 0)
3165 RETPUSHUNDEF;
d7f0a2f4
NC		 3166 if (op_type == OP_FTIS)
3167 RETPUSHYES;
957b0e1d 3168 {
d7f0a2f4
NC		 3169 /* You can't dTARGET inside OP_FTIS, because you'll get
3170 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3171 dTARGET;
d7f0a2f4 3172 switch (op_type) {
957b0e1d
NC		 3173 case OP_FTSIZE:
3174#if Off_t_size > IVSIZE
3175 PUSHn(PL_statcache.st_size);
3176#else
3177 PUSHi(PL_statcache.st_size);
3178#endif
3179 break;
3180 case OP_FTMTIME:
3181 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3182 break;
3183 case OP_FTATIME:
3184 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3185 break;
3186 case OP_FTCTIME:
3187 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3188 break;
3189 }
3190 }
3191 RETURN;
a0d0e21e
LW		 3192}
3193
a0d0e21e
LW		 3194PP(pp_ftrowned)
3195{
97aff369 3196 dVAR;
fbb0b3b3 3197 I32 result;
07fe7c6a 3198 char opchar = '?';
2a3ff820 3199 dSP;
17ad201a 3200
7fb13887
BM		 3201 switch (PL_op->op_type) {
3202 case OP_FTROWNED: opchar = 'O'; break;
3203 case OP_FTEOWNED: opchar = 'o'; break;
3204 case OP_FTZERO: opchar = 'z'; break;
3205 case OP_FTSOCK: opchar = 'S'; break;
3206 case OP_FTCHR: opchar = 'c'; break;
3207 case OP_FTBLK: opchar = 'b'; break;
3208 case OP_FTFILE: opchar = 'f'; break;
3209 case OP_FTDIR: opchar = 'd'; break;
3210 case OP_FTPIPE: opchar = 'p'; break;
3211 case OP_FTSUID: opchar = 'u'; break;
3212 case OP_FTSGID: opchar = 'g'; break;
3213 case OP_FTSVTX: opchar = 'k'; break;
3214 }
6f1401dc 3215 tryAMAGICftest_MG(opchar);
7fb13887 3216
1b0124a7
JD		 3217 STACKED_FTEST_CHECK;
3218
17ad201a
NC		 3219 /* I believe that all these three are likely to be defined on most every
3220 system these days. */
3221#ifndef S_ISUID
c410dd6a 3222 if(PL_op->op_type == OP_FTSUID) {
1b0124a7
JD		 3223 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3224 (void) POPs;
17ad201a 3225 RETPUSHNO;
c410dd6a 3226 }
17ad201a
NC		 3227#endif
3228#ifndef S_ISGID
c410dd6a 3229 if(PL_op->op_type == OP_FTSGID) {
1b0124a7
JD		 3230 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3231 (void) POPs;
17ad201a 3232 RETPUSHNO;
c410dd6a 3233 }
17ad201a
NC		 3234#endif
3235#ifndef S_ISVTX
c410dd6a 3236 if(PL_op->op_type == OP_FTSVTX) {
1b0124a7
JD		 3237 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3238 (void) POPs;
17ad201a 3239 RETPUSHNO;
c410dd6a 3240 }
17ad201a
NC		 3241#endif
3242
40c852de 3243 result = my_stat_flags(0);
fbb0b3b3 3244 SPAGAIN;
a0d0e21e
LW		 3245 if (result < 0)
3246 RETPUSHUNDEF;
f1cb2d48
NC		 3247 switch (PL_op->op_type) {
3248 case OP_FTROWNED:
9ab9fa88 3249 if (PL_statcache.st_uid == PL_uid)
f1cb2d48
NC		 3250 RETPUSHYES;
3251 break;
3252 case OP_FTEOWNED:
3253 if (PL_statcache.st_uid == PL_euid)
3254 RETPUSHYES;
3255 break;
3256 case OP_FTZERO:
3257 if (PL_statcache.st_size == 0)
3258 RETPUSHYES;
3259 break;
3260 case OP_FTSOCK:
3261 if (S_ISSOCK(PL_statcache.st_mode))
3262 RETPUSHYES;
3263 break;
3264 case OP_FTCHR:
3265 if (S_ISCHR(PL_statcache.st_mode))
3266 RETPUSHYES;
3267 break;
3268 case OP_FTBLK:
3269 if (S_ISBLK(PL_statcache.st_mode))
3270 RETPUSHYES;
3271 break;
3272 case OP_FTFILE:
3273 if (S_ISREG(PL_statcache.st_mode))
3274 RETPUSHYES;
3275 break;
3276 case OP_FTDIR:
3277 if (S_ISDIR(PL_statcache.st_mode))
3278 RETPUSHYES;
3279 break;
3280 case OP_FTPIPE:
3281 if (S_ISFIFO(PL_statcache.st_mode))
3282 RETPUSHYES;
3283 break;
a0d0e21e 3284#ifdef S_ISUID
17ad201a
NC		 3285 case OP_FTSUID:
3286 if (PL_statcache.st_mode & S_ISUID)
3287 RETPUSHYES;
3288 break;
a0d0e21e 3289#endif
a0d0e21e 3290#ifdef S_ISGID
17ad201a
NC		 3291 case OP_FTSGID:
3292 if (PL_statcache.st_mode & S_ISGID)
3293 RETPUSHYES;
3294 break;
3295#endif
3296#ifdef S_ISVTX
3297 case OP_FTSVTX:
3298 if (PL_statcache.st_mode & S_ISVTX)
3299 RETPUSHYES;
3300 break;
a0d0e21e 3301#endif
17ad201a 3302 }
a0d0e21e
LW		 3303 RETPUSHNO;
3304}
3305
17ad201a 3306PP(pp_ftlink)
a0d0e21e 3307{
97aff369 3308 dVAR;
39644a26 3309 dSP;
500ff13f 3310 I32 result;
07fe7c6a 3311
6f1401dc 3312 tryAMAGICftest_MG('l');
40c852de 3313 result = my_lstat_flags(0);
500ff13f
BM		 3314 SPAGAIN;
3315
a0d0e21e
LW		 3316 if (result < 0)
3317 RETPUSHUNDEF;
17ad201a 3318 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e 3319 RETPUSHYES;
a0d0e21e
LW		 3320 RETPUSHNO;
3321}
3322
3323PP(pp_fttty)
3324{
97aff369 3325 dVAR;
39644a26 3326 dSP;
a0d0e21e
LW		 3327 int fd;
3328 GV *gv;
a0714e2c 3329 SV *tmpsv = NULL;
0784aae0 3330 char *name = NULL;
40c852de 3331 STRLEN namelen;
fb73857a 3332
6f1401dc 3333 tryAMAGICftest_MG('t');
07fe7c6a 3334
fbb0b3b3
RGS		 3335 STACKED_FTEST_CHECK;
3336
533c011a 3337 if (PL_op->op_flags & OPf_REF)
146174a9 3338 gv = cGVOP_gv;
13be902c 3339 else if (isGV_with_GP(TOPs))
159b6efe 3340 gv = MUTABLE_GV(POPs);
fb73857a 3341 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
159b6efe 3342 gv = MUTABLE_GV(SvRV(POPs));
40c852de
DM		 3343 else {
3344 tmpsv = POPs;
3345 name = SvPV_nomg(tmpsv, namelen);
3346 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3347 }
fb73857a 3348
a0d0e21e 3349 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3350 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
7a5fd60d 3351 else if (tmpsv && SvOK(tmpsv)) {
40c852de
DM		 3352 if (isDIGIT(*name))
3353 fd = atoi(name);
7a5fd60d
NC		 3354 else
3355 RETPUSHUNDEF;
3356 }
a0d0e21e
LW		 3357 else
3358 RETPUSHUNDEF;
6ad3d225 3359 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3360 RETPUSHYES;
3361 RETPUSHNO;
3362}
3363
16d20bd9
AD		 3364#if defined(atarist) /* this will work with atariST. Configure will
3365 make guesses for other systems. */
3366# define FILE_base(f) ((f)->_base)
3367# define FILE_ptr(f) ((f)->_ptr)
3368# define FILE_cnt(f) ((f)->_cnt)
3369# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3370#endif
3371
3372PP(pp_fttext)
3373{
97aff369 3374 dVAR;
39644a26 3375 dSP;
a0d0e21e
LW		 3376 I32 i;
3377 I32 len;
3378 I32 odd = 0;
3379 STDCHAR tbuf[512];
3380 register STDCHAR *s;
3381 register IO *io;
5f05dabc 3382 register SV *sv;
3383 GV *gv;
146174a9 3384 PerlIO *fp;
a0d0e21e 3385
6f1401dc 3386 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
07fe7c6a 3387
fbb0b3b3
RGS		 3388 STACKED_FTEST_CHECK;
3389
533c011a 3390 if (PL_op->op_flags & OPf_REF)
146174a9 3391 gv = cGVOP_gv;
13be902c 3392 else if (isGV_with_GP(TOPs))
159b6efe 3393 gv = MUTABLE_GV(POPs);
5f05dabc 3394 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
159b6efe 3395 gv = MUTABLE_GV(SvRV(POPs));
5f05dabc 3396 else
a0714e2c 3397 gv = NULL;
5f05dabc 3398
3399 if (gv) {
a0d0e21e 3400 EXTEND(SP, 1);
3280af22
NIS		 3401 if (gv == PL_defgv) {
3402 if (PL_statgv)
3403 io = GvIO(PL_statgv);
a0d0e21e 3404 else {
3280af22 3405 sv = PL_statname;
a0d0e21e
LW		 3406 goto really_filename;
3407 }
3408 }
3409 else {
3280af22
NIS		 3410 PL_statgv = gv;
3411 PL_laststatval = -1;
76f68e9b 3412 sv_setpvs(PL_statname, "");
3280af22 3413 io = GvIO(PL_statgv);
a0d0e21e
LW		 3414 }
3415 if (io && IoIFP(io)) {
5f05dabc 3416 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3417 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3418 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3419 if (PL_laststatval < 0)
5f05dabc 3420 RETPUSHUNDEF;
9cbac4c7 3421 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3422 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW