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