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