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