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