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