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