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