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