This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add basic tests for select()
[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);
4633a7c4 1227
4633a7c4 1228 if (!egv)
3280af22 1229 egv = PL_defoutgv;
099be4f1 1230 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
4633a7c4 1231 if (! hv)
3280af22 1232 XPUSHs(&PL_sv_undef);
4633a7c4 1233 else {
9e964fea 1234 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE);
f86702cc 1235 if (gvp && *gvp == egv) {
bd61b366 1236 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
f86702cc
PP
1237 XPUSHTARG;
1238 }
1239 else {
ad64d0ec 1240 mXPUSHs(newRV(MUTABLE_SV(egv)));
f86702cc 1241 }
4633a7c4
LW
1242 }
1243
1244 if (newdefout) {
ded8aa31
GS
1245 if (!GvIO(newdefout))
1246 gv_IOadd(newdefout);
4633a7c4
LW
1247 setdefout(newdefout);
1248 }
1249
a0d0e21e
LW
1250 RETURN;
1251}
1252
1253PP(pp_getc)
1254{
27da23d5 1255 dVAR; dSP; dTARGET;
30901a8a
FC
1256 GV * const gv =
1257 MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
9c9f25b8 1258 IO *const io = GvIO(gv);
2ae324a7 1259
ac3697cd
NC
1260 if (MAXARG == 0)
1261 EXTEND(SP, 1);
1262
9c9f25b8 1263 if (io) {
a5e1d062 1264 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1265 if (mg) {
0240605e 1266 const U32 gimme = GIMME_V;
d682515d 1267 Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0);
0240605e
NC
1268 if (gimme == G_SCALAR) {
1269 SPAGAIN;
a79db61d 1270 SvSetMagicSV_nosteal(TARG, TOPs);
0240605e
NC
1271 }
1272 return NORMAL;
a79db61d 1273 }
2ae324a7 1274 }
90133b69 1275 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
51087808 1276 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
831e4cc3 1277 report_evil_fh(gv);
b5fe5ca2 1278 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1279 RETPUSHUNDEF;
90133b69 1280 }
bbce6d69 1281 TAINT;
76f68e9b 1282 sv_setpvs(TARG, " ");
9bc64814 1283 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
7d59b7e4
NIS
1284 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1285 /* Find out how many bytes the char needs */
aa07b2f6 1286 Size_t len = UTF8SKIP(SvPVX_const(TARG));
7d59b7e4
NIS
1287 if (len > 1) {
1288 SvGROW(TARG,len+1);
1289 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1290 SvCUR_set(TARG,1+len);
1291 }
1292 SvUTF8_on(TARG);
1293 }
a0d0e21e
LW
1294 PUSHTARG;
1295 RETURN;
1296}
1297
76e3520e 1298STATIC OP *
cea2e8a9 1299S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1300{
27da23d5 1301 dVAR;
c09156bb 1302 register PERL_CONTEXT *cx;
f54cb97a 1303 const I32 gimme = GIMME_V;
a0d0e21e 1304
7918f24d
NC
1305 PERL_ARGS_ASSERT_DOFORM;
1306
7b190374
NC
1307 if (cv && CvCLONE(cv))
1308 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1309
a0d0e21e
LW
1310 ENTER;
1311 SAVETMPS;
1312
146174a9 1313 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
10067d9a 1314 PUSHFORMAT(cx, retop);
fd617465
DM
1315 SAVECOMPPAD();
1316 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
a0d0e21e 1317
4633a7c4 1318 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW
1319 return CvSTART(cv);
1320}
1321
1322PP(pp_enterwrite)
1323{
97aff369 1324 dVAR;
39644a26 1325 dSP;
a0d0e21e
LW
1326 register GV *gv;
1327 register IO *io;
1328 GV *fgv;
07822e36
JH
1329 CV *cv = NULL;
1330 SV *tmpsv = NULL;
a0d0e21e 1331
2addaaf3 1332 if (MAXARG == 0) {
3280af22 1333 gv = PL_defoutgv;
2addaaf3
NC
1334 EXTEND(SP, 1);
1335 }
a0d0e21e 1336 else {
159b6efe 1337 gv = MUTABLE_GV(POPs);
a0d0e21e 1338 if (!gv)
3280af22 1339 gv = PL_defoutgv;
a0d0e21e 1340 }
a0d0e21e
LW
1341 io = GvIO(gv);
1342 if (!io) {
1343 RETPUSHNO;
1344 }
1345 if (IoFMT_GV(io))
1346 fgv = IoFMT_GV(io);
1347 else
1348 fgv = gv;
1349
a79db61d
AL
1350 if (!fgv)
1351 goto not_a_format_reference;
1352
a0d0e21e 1353 cv = GvFORM(fgv);
a0d0e21e 1354 if (!cv) {
10edeb5d 1355 tmpsv = sv_newmortal();
f4a7049d 1356 gv_efullname4(tmpsv, fgv, NULL, FALSE);
bf29d05f
BF
1357 if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv))
1358 DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
a79db61d
AL
1359
1360 not_a_format_reference:
cea2e8a9 1361 DIE(aTHX_ "Not a format reference");
a0d0e21e 1362 }
44a8e56a 1363 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1364 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW
1365}
1366
1367PP(pp_leavewrite)
1368{
27da23d5 1369 dVAR; dSP;
f9c764c5 1370 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1b6737cc 1371 register IO * const io = GvIOp(gv);
8b8cacda 1372 PerlIO *ofp;
760ac839 1373 PerlIO *fp;
8772537c
AL
1374 SV **newsp;
1375 I32 gimme;
c09156bb 1376 register PERL_CONTEXT *cx;
8f89e5a9 1377 OP *retop;
a0d0e21e 1378
8b8cacda 1379 if (!io || !(ofp = IoOFP(io)))
1380 goto forget_top;
1381
760ac839 1382 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1383 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
8b8cacda 1384
3280af22
NIS
1385 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1386 PL_formtarget != PL_toptarget)
a0d0e21e 1387 {
4633a7c4
LW
1388 GV *fgv;
1389 CV *cv;
a0d0e21e
LW
1390 if (!IoTOP_GV(io)) {
1391 GV *topgv;
a0d0e21e
LW
1392
1393 if (!IoTOP_NAME(io)) {
1b6737cc 1394 SV *topname;
a0d0e21e
LW
1395 if (!IoFMT_NAME(io))
1396 IoFMT_NAME(io) = savepv(GvNAME(gv));
d0c0e7dd
FC
1397 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1398 HEKfARG(GvNAME_HEK(gv))));
f776e3cd 1399 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
748a9306 1400 if ((topgv && GvFORM(topgv)) ||
fafc274c 1401 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
2e0de35c 1402 IoTOP_NAME(io) = savesvpv(topname);
a0d0e21e 1403 else
89529cee 1404 IoTOP_NAME(io) = savepvs("top");
a0d0e21e 1405 }
f776e3cd 1406 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
a0d0e21e 1407 if (!topgv || !GvFORM(topgv)) {
b929a54b 1408 IoLINES_LEFT(io) = IoPAGE_LEN(io);
a0d0e21e
LW
1409 goto forget_top;
1410 }
1411 IoTOP_GV(io) = topgv;
1412 }
748a9306
LW
1413 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1414 I32 lines = IoLINES_LEFT(io);
504618e9 1415 const char *s = SvPVX_const(PL_formtarget);
8e07c86e
AD
1416 if (lines <= 0) /* Yow, header didn't even fit!!! */
1417 goto forget_top;
748a9306
LW
1418 while (lines-- > 0) {
1419 s = strchr(s, '\n');
1420 if (!s)
1421 break;
1422 s++;
1423 }
1424 if (s) {
f54cb97a 1425 const STRLEN save = SvCUR(PL_formtarget);
aa07b2f6 1426 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
d75029d0
NIS
1427 do_print(PL_formtarget, ofp);
1428 SvCUR_set(PL_formtarget, save);
3280af22
NIS
1429 sv_chop(PL_formtarget, s);
1430 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1431 }
1432 }
a0d0e21e 1433 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
d75029d0 1434 do_print(PL_formfeed, ofp);
a0d0e21e
LW
1435 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1436 IoPAGE(io)++;
3280af22 1437 PL_formtarget = PL_toptarget;
748a9306 1438 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW
1439 fgv = IoTOP_GV(io);
1440 if (!fgv)
cea2e8a9 1441 DIE(aTHX_ "bad top format reference");
4633a7c4 1442 cv = GvFORM(fgv);
1df70142
AL
1443 if (!cv) {
1444 SV * const sv = sv_newmortal();
bd61b366 1445 gv_efullname4(sv, fgv, NULL, FALSE);
bf29d05f
BF
1446 if (SvPOK(sv) && *SvPV_nolen_const(sv))
1447 DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
0e528f24
JH
1448 else
1449 DIE(aTHX_ "Undefined top format called");
4633a7c4 1450 }
0e528f24 1451 return doform(cv, gv, PL_op);
a0d0e21e
LW
1452 }
1453
1454 forget_top:
3280af22 1455 POPBLOCK(cx,PL_curpm);
a0d0e21e 1456 POPFORMAT(cx);
8f89e5a9 1457 retop = cx->blk_sub.retop;
a0d0e21e
LW
1458 LEAVE;
1459
1460 fp = IoOFP(io);
1461 if (!fp) {
7716c5c5
NC
1462 if (IoIFP(io))
1463 report_wrongway_fh(gv, '<');
c521cf7c 1464 else
7716c5c5 1465 report_evil_fh(gv);
3280af22 1466 PUSHs(&PL_sv_no);
a0d0e21e
LW
1467 }
1468 else {
3280af22 1469 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
a2a5de95 1470 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
a0d0e21e 1471 }
d75029d0 1472 if (!do_print(PL_formtarget, fp))
3280af22 1473 PUSHs(&PL_sv_no);
a0d0e21e 1474 else {
3280af22
NIS
1475 FmLINES(PL_formtarget) = 0;
1476 SvCUR_set(PL_formtarget, 0);
1477 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1478 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1479 (void)PerlIO_flush(fp);
3280af22 1480 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1481 }
1482 }
9cbac4c7 1483 /* bad_ofp: */
3280af22 1484 PL_formtarget = PL_bodytarget;
a0d0e21e 1485 PUTBACK;
29033a8a
SH
1486 PERL_UNUSED_VAR(newsp);
1487 PERL_UNUSED_VAR(gimme);
8f89e5a9 1488 return retop;
a0d0e21e
LW
1489}
1490
1491PP(pp_prtf)
1492{
27da23d5 1493 dVAR; dSP; dMARK; dORIGMARK;
760ac839 1494 PerlIO *fp;
26db47c4 1495 SV *sv;
a0d0e21e 1496
159b6efe
NC
1497 GV * const gv
1498 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
9c9f25b8 1499 IO *const io = GvIO(gv);
46fc3d4c 1500
9c9f25b8 1501 if (io) {
a5e1d062 1502 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d
AL
1503 if (mg) {
1504 if (MARK == ORIGMARK) {
1505 MEXTEND(SP, 1);
1506 ++MARK;
1507 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1508 ++SP;
1509 }
d682515d
NC
1510 return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io),
1511 mg,
1512 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1513 sp - mark);
a79db61d 1514 }
46fc3d4c
PP
1515 }
1516
561b68a9 1517 sv = newSV(0);
9c9f25b8 1518 if (!io) {
51087808 1519 report_evil_fh(gv);
93189314 1520 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
1521 goto just_say_no;
1522 }
1523 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
1524 if (IoIFP(io))
1525 report_wrongway_fh(gv, '<');
1526 else if (ckWARN(WARN_CLOSED))
1527 report_evil_fh(gv);
93189314 1528 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
1529 goto just_say_no;
1530 }
1531 else {
1532 do_sprintf(sv, SP - MARK, MARK + 1);
1533 if (!do_print(sv, fp))
1534 goto just_say_no;
1535
1536 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1537 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1538 goto just_say_no;
1539 }
1540 SvREFCNT_dec(sv);
1541 SP = ORIGMARK;
3280af22 1542 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1543 RETURN;
1544
1545 just_say_no:
1546 SvREFCNT_dec(sv);
1547 SP = ORIGMARK;
3280af22 1548 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1549 RETURN;
1550}
1551
c07a80fd
PP
1552PP(pp_sysopen)
1553{
97aff369 1554 dVAR;
39644a26 1555 dSP;
de5e49e1 1556 const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
1df70142 1557 const int mode = POPi;
1b6737cc 1558 SV * const sv = POPs;
159b6efe 1559 GV * const gv = MUTABLE_GV(POPs);
1b6737cc 1560 STRLEN len;
c07a80fd 1561
4592e6ca 1562 /* Need TIEHANDLE method ? */
1b6737cc 1563 const char * const tmps = SvPV_const(sv, len);
e62f0680 1564 /* FIXME? do_open should do const */
4608196e 1565 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
c07a80fd 1566 IoLINES(GvIOp(gv)) = 0;
3280af22 1567 PUSHs(&PL_sv_yes);
c07a80fd
PP
1568 }
1569 else {
3280af22 1570 PUSHs(&PL_sv_undef);
c07a80fd
PP
1571 }
1572 RETURN;
1573}
1574
a0d0e21e
LW
1575PP(pp_sysread)
1576{
27da23d5 1577 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
0b423688 1578 SSize_t offset;
a0d0e21e
LW
1579 IO *io;
1580 char *buffer;
0b423688 1581 STRLEN orig_size;
5b54f415 1582 SSize_t length;
eb5c063a 1583 SSize_t count;
748a9306 1584 SV *bufsv;
a0d0e21e 1585 STRLEN blen;
eb5c063a 1586 int fp_utf8;
1dd30107
NC
1587 int buffer_utf8;
1588 SV *read_target;
eb5c063a
NIS
1589 Size_t got = 0;
1590 Size_t wanted;
1d636c13 1591 bool charstart = FALSE;
87330c3c
JH
1592 STRLEN charskip = 0;
1593 STRLEN skip = 0;
a0d0e21e 1594
159b6efe 1595 GV * const gv = MUTABLE_GV(*++MARK);
5b468f54 1596 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1b6737cc 1597 && gv && (io = GvIO(gv)) )
137443ea 1598 {
a5e1d062 1599 const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1b6737cc 1600 if (mg) {
d682515d
NC
1601 return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg,
1602 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1603 sp - mark);
1b6737cc 1604 }
2ae324a7
PP
1605 }
1606
a0d0e21e
LW
1607 if (!gv)
1608 goto say_undef;
748a9306 1609 bufsv = *++MARK;
ff68c719 1610 if (! SvOK(bufsv))
76f68e9b 1611 sv_setpvs(bufsv, "");
a0d0e21e 1612 length = SvIVx(*++MARK);
748a9306 1613 SETERRNO(0,0);
a0d0e21e
LW
1614 if (MARK < SP)
1615 offset = SvIVx(*++MARK);
1616 else
1617 offset = 0;
1618 io = GvIO(gv);
b5fe5ca2 1619 if (!io || !IoIFP(io)) {
51087808 1620 report_evil_fh(gv);
b5fe5ca2 1621 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1622 goto say_undef;
b5fe5ca2 1623 }
0064a8a9 1624 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
7d59b7e4 1625 buffer = SvPVutf8_force(bufsv, blen);
1e54db1a 1626 /* UTF-8 may not have been set if they are all low bytes */
eb5c063a 1627 SvUTF8_on(bufsv);
9b9d7ce8 1628 buffer_utf8 = 0;
7d59b7e4
NIS
1629 }
1630 else {
1631 buffer = SvPV_force(bufsv, blen);
1dd30107 1632 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
7d59b7e4
NIS
1633 }
1634 if (length < 0)
1635 DIE(aTHX_ "Negative length");
eb5c063a 1636 wanted = length;
7d59b7e4 1637
d0965105
JH
1638 charstart = TRUE;
1639 charskip = 0;
87330c3c 1640 skip = 0;
d0965105 1641
a0d0e21e 1642#ifdef HAS_SOCKET
533c011a 1643 if (PL_op->op_type == OP_RECV) {
0b423688 1644 Sock_size_t bufsize;
46fc3d4c 1645 char namebuf[MAXPATHLEN];
17a8c7ba 1646#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
490ab354
JH
1647 bufsize = sizeof (struct sockaddr_in);
1648#else
46fc3d4c 1649 bufsize = sizeof namebuf;
490ab354 1650#endif
abf95952
IZ
1651#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1652 if (bufsize >= 256)
1653 bufsize = 255;
1654#endif
eb160463 1655 buffer = SvGROW(bufsv, (STRLEN)(length+1));
bbce6d69 1656 /* 'offset' means 'flags' here */
eb5c063a 1657 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
10edeb5d 1658 (struct sockaddr *)namebuf, &bufsize);
eb5c063a 1659 if (count < 0)
a0d0e21e 1660 RETPUSHUNDEF;
8eb023a9
DM
1661 /* MSG_TRUNC can give oversized count; quietly lose it */
1662 if (count > length)
1663 count = length;
4107cc59
OF
1664#ifdef EPOC
1665 /* Bogus return without padding */
1666 bufsize = sizeof (struct sockaddr_in);
1667#endif
eb5c063a 1668 SvCUR_set(bufsv, count);
748a9306
LW
1669 *SvEND(bufsv) = '\0';
1670 (void)SvPOK_only(bufsv);
eb5c063a
NIS
1671 if (fp_utf8)
1672 SvUTF8_on(bufsv);
748a9306 1673 SvSETMAGIC(bufsv);
aac0dd9a 1674 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1675 if (!(IoFLAGS(io) & IOf_UNTAINT))
1676 SvTAINTED_on(bufsv);
a0d0e21e 1677 SP = ORIGMARK;
46fc3d4c 1678 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1679 PUSHs(TARG);
1680 RETURN;
1681 }
a0d0e21e 1682#endif
eb5c063a
NIS
1683 if (DO_UTF8(bufsv)) {
1684 /* offset adjust in characters not bytes */
1685 blen = sv_len_utf8(bufsv);
7d59b7e4 1686 }
bbce6d69 1687 if (offset < 0) {
0b423688 1688 if (-offset > (SSize_t)blen)
cea2e8a9 1689 DIE(aTHX_ "Offset outside string");
bbce6d69
PP
1690 offset += blen;
1691 }
eb5c063a
NIS
1692 if (DO_UTF8(bufsv)) {
1693 /* convert offset-as-chars to offset-as-bytes */
6960c29a
CH
1694 if (offset >= (int)blen)
1695 offset += SvCUR(bufsv) - blen;
1696 else
1697 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
eb5c063a
NIS
1698 }
1699 more_bytes:
0b423688 1700 orig_size = SvCUR(bufsv);
1dd30107
NC
1701 /* Allocating length + offset + 1 isn't perfect in the case of reading
1702 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1703 unduly.
1704 (should be 2 * length + offset + 1, or possibly something longer if
1705 PL_encoding is true) */
eb160463 1706 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
0b423688
TC
1707 if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1708 Zero(buffer+orig_size, offset-orig_size, char);
cd52b7b2 1709 }
eb5c063a 1710 buffer = buffer + offset;
1dd30107
NC
1711 if (!buffer_utf8) {
1712 read_target = bufsv;
1713 } else {
1714 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1715 concatenate it to the current buffer. */
1716
1717 /* Truncate the existing buffer to the start of where we will be
1718 reading to: */
1719 SvCUR_set(bufsv, offset);
1720
1721 read_target = sv_newmortal();
862a34c6 1722 SvUPGRADE(read_target, SVt_PV);
fe2774ed 1723 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1dd30107 1724 }
eb5c063a 1725
533c011a 1726 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1727#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1728 if (IoTYPE(io) == IoTYPE_SOCKET) {
eb5c063a
NIS
1729 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1730 buffer, length, 0);
a7092146
GS
1731 }
1732 else
1733#endif
1734 {
eb5c063a
NIS
1735 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1736 buffer, length);
a7092146 1737 }
a0d0e21e
LW
1738 }
1739 else
1740#ifdef HAS_SOCKET__bad_code_maybe
50952442 1741 if (IoTYPE(io) == IoTYPE_SOCKET) {
0b423688 1742 Sock_size_t bufsize;
46fc3d4c 1743 char namebuf[MAXPATHLEN];
490ab354
JH
1744#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1745 bufsize = sizeof (struct sockaddr_in);
1746#else
46fc3d4c 1747 bufsize = sizeof namebuf;
490ab354 1748#endif
eb5c063a 1749 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
46fc3d4c 1750 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1751 }
1752 else
1753#endif
3b02c43c 1754 {
eb5c063a
NIS
1755 count = PerlIO_read(IoIFP(io), buffer, length);
1756 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1757 if (count == 0 && PerlIO_error(IoIFP(io)))
1758 count = -1;
3b02c43c 1759 }
eb5c063a 1760 if (count < 0) {
7716c5c5 1761 if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1762 report_wrongway_fh(gv, '>');
a0d0e21e 1763 goto say_undef;
af8c498a 1764 }
aa07b2f6 1765 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1dd30107
NC
1766 *SvEND(read_target) = '\0';
1767 (void)SvPOK_only(read_target);
0064a8a9 1768 if (fp_utf8 && !IN_BYTES) {
eb5c063a 1769 /* Look at utf8 we got back and count the characters */
1df70142 1770 const char *bend = buffer + count;
eb5c063a 1771 while (buffer < bend) {
d0965105
JH
1772 if (charstart) {
1773 skip = UTF8SKIP(buffer);
1774 charskip = 0;
1775 }
1776 if (buffer - charskip + skip > bend) {
eb5c063a
NIS
1777 /* partial character - try for rest of it */
1778 length = skip - (bend-buffer);
aa07b2f6 1779 offset = bend - SvPVX_const(bufsv);
d0965105
JH
1780 charstart = FALSE;
1781 charskip += count;
eb5c063a
NIS
1782 goto more_bytes;
1783 }
1784 else {
1785 got++;
1786 buffer += skip;
d0965105
JH
1787 charstart = TRUE;
1788 charskip = 0;
eb5c063a
NIS
1789 }
1790 }
1791 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1792 provided amount read (count) was what was requested (length)
1793 */
1794 if (got < wanted && count == length) {
d0965105 1795 length = wanted - got;
aa07b2f6 1796 offset = bend - SvPVX_const(bufsv);
eb5c063a
NIS
1797 goto more_bytes;
1798 }
1799 /* return value is character count */
1800 count = got;
1801 SvUTF8_on(bufsv);
1802 }
1dd30107
NC
1803 else if (buffer_utf8) {
1804 /* Let svcatsv upgrade the bytes we read in to utf8.
1805 The buffer is a mortal so will be freed soon. */
1806 sv_catsv_nomg(bufsv, read_target);
1807 }
748a9306 1808 SvSETMAGIC(bufsv);
aac0dd9a 1809 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1810 if (!(IoFLAGS(io) & IOf_UNTAINT))
1811 SvTAINTED_on(bufsv);
a0d0e21e 1812 SP = ORIGMARK;
eb5c063a 1813 PUSHi(count);
a0d0e21e
LW
1814 RETURN;
1815
1816 say_undef:
1817 SP = ORIGMARK;
1818 RETPUSHUNDEF;
1819}
1820
60504e18 1821PP(pp_syswrite)
a0d0e21e 1822{
27da23d5 1823 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
748a9306 1824 SV *bufsv;
83003860 1825 const char *buffer;
8c99d73e 1826 SSize_t retval;
a0d0e21e 1827 STRLEN blen;
c9cb0f41 1828 STRLEN orig_blen_bytes;
64a1bc8e 1829 const int op_type = PL_op->op_type;
c9cb0f41
NC
1830 bool doing_utf8;
1831 U8 *tmpbuf = NULL;
159b6efe 1832 GV *const gv = MUTABLE_GV(*++MARK);
91472ad4
NC
1833 IO *const io = GvIO(gv);
1834
1835 if (op_type == OP_SYSWRITE && io) {
a5e1d062 1836 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1837 if (mg) {
a79db61d 1838 if (MARK == SP - 1) {
c8834ab7
TC
1839 SV *sv = *SP;
1840 mXPUSHi(sv_len(sv));
a79db61d
AL
1841 PUTBACK;
1842 }
1843
d682515d
NC
1844 return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg,
1845 G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1846 sp - mark);
64a1bc8e 1847 }
1d603a67 1848 }
a0d0e21e
LW
1849 if (!gv)
1850 goto say_undef;
64a1bc8e 1851
748a9306 1852 bufsv = *++MARK;
64a1bc8e 1853
748a9306 1854 SETERRNO(0,0);
cf167416 1855 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
8c99d73e 1856 retval = -1;
51087808
NC
1857 if (io && IoIFP(io))
1858 report_wrongway_fh(gv, '<');
1859 else
1860 report_evil_fh(gv);
b5fe5ca2 1861 SETERRNO(EBADF,RMS_IFI);
7d59b7e4
NIS
1862 goto say_undef;
1863 }
1864
c9cb0f41
NC
1865 /* Do this first to trigger any overloading. */
1866 buffer = SvPV_const(bufsv, blen);
1867 orig_blen_bytes = blen;
1868 doing_utf8 = DO_UTF8(bufsv);
1869
7d59b7e4 1870 if (PerlIO_isutf8(IoIFP(io))) {
6aa2f6a7 1871 if (!SvUTF8(bufsv)) {
c9cb0f41
NC
1872 /* We don't modify the original scalar. */
1873 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1874 buffer = (char *) tmpbuf;
1875 doing_utf8 = TRUE;
1876 }
a0d0e21e 1877 }
c9cb0f41
NC
1878 else if (doing_utf8) {
1879 STRLEN tmplen = blen;
a79db61d 1880 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
c9cb0f41
NC
1881 if (!doing_utf8) {
1882 tmpbuf = result;
1883 buffer = (char *) tmpbuf;
1884 blen = tmplen;
1885 }
1886 else {
1887 assert((char *)result == buffer);
1888 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1889 }
7d59b7e4
NIS
1890 }
1891
e2712234 1892#ifdef HAS_SOCKET
7627e6d0 1893 if (op_type == OP_SEND) {
e2712234
NC
1894 const int flags = SvIVx(*++MARK);
1895 if (SP > MARK) {
1896 STRLEN mlen;
1897 char * const sockbuf = SvPVx(*++MARK, mlen);
1898 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1899 flags, (struct sockaddr *)sockbuf, mlen);
1900 }
1901 else {
1902 retval
1903 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1904 }
7627e6d0
NC
1905 }
1906 else
e2712234 1907#endif
7627e6d0 1908 {
c9cb0f41
NC
1909 Size_t length = 0; /* This length is in characters. */
1910 STRLEN blen_chars;
7d59b7e4 1911 IV offset;
c9cb0f41
NC
1912
1913 if (doing_utf8) {
1914 if (tmpbuf) {
1915 /* The SV is bytes, and we've had to upgrade it. */
1916 blen_chars = orig_blen_bytes;
1917 } else {
1918 /* The SV really is UTF-8. */
1919 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1920 /* Don't call sv_len_utf8 again because it will call magic
1921 or overloading a second time, and we might get back a
1922 different result. */
9a206dfd 1923 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
c9cb0f41
NC
1924 } else {
1925 /* It's safe, and it may well be cached. */
1926 blen_chars = sv_len_utf8(bufsv);
1927 }
1928 }
1929 } else {
1930 blen_chars = blen;
1931 }
1932
1933 if (MARK >= SP) {
1934 length = blen_chars;
1935 } else {
1936#if Size_t_size > IVSIZE
1937 length = (Size_t)SvNVx(*++MARK);
1938#else
1939 length = (Size_t)SvIVx(*++MARK);
1940#endif
4b0c4b6f
NC
1941 if ((SSize_t)length < 0) {
1942 Safefree(tmpbuf);
c9cb0f41 1943 DIE(aTHX_ "Negative length");
4b0c4b6f 1944 }
7d59b7e4 1945 }
c9cb0f41 1946
bbce6d69 1947 if (MARK < SP) {
a0d0e21e 1948 offset = SvIVx(*++MARK);
bbce6d69 1949 if (offset < 0) {
4b0c4b6f
NC
1950 if (-offset > (IV)blen_chars) {
1951 Safefree(tmpbuf);
cea2e8a9 1952 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1953 }
c9cb0f41 1954 offset += blen_chars;
3c946528 1955 } else if (offset > (IV)blen_chars) {
4b0c4b6f 1956 Safefree(tmpbuf);
cea2e8a9 1957 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1958 }
bbce6d69 1959 } else
a0d0e21e 1960 offset = 0;
c9cb0f41
NC
1961 if (length > blen_chars - offset)
1962 length = blen_chars - offset;
1963 if (doing_utf8) {
1964 /* Here we convert length from characters to bytes. */
1965 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1966 /* Either we had to convert the SV, or the SV is magical, or
1967 the SV has overloading, in which case we can't or mustn't
1968 or mustn't call it again. */
1969
1970 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1971 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1972 } else {
1973 /* It's a real UTF-8 SV, and it's not going to change under
1974 us. Take advantage of any cache. */
1975 I32 start = offset;
1976 I32 len_I32 = length;
1977
1978 /* Convert the start and end character positions to bytes.
1979 Remember that the second argument to sv_pos_u2b is relative
1980 to the first. */
1981 sv_pos_u2b(bufsv, &start, &len_I32);
1982
1983 buffer += start;
1984 length = len_I32;
1985 }
7d59b7e4
NIS
1986 }
1987 else {
1988 buffer = buffer+offset;
1989 }
a7092146 1990#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1991 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1992 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1993 buffer, length, 0);
a7092146
GS
1994 }
1995 else
1996#endif
1997 {
94e4c244 1998 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1999 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
7d59b7e4 2000 buffer, length);
a7092146 2001 }
a0d0e21e 2002 }
c9cb0f41 2003
8c99d73e 2004 if (retval < 0)
a0d0e21e
LW
2005 goto say_undef;
2006 SP = ORIGMARK;
c9cb0f41 2007 if (doing_utf8)
f36eea10 2008 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
4b0c4b6f 2009
a79db61d 2010 Safefree(tmpbuf);
8c99d73e
GS
2011#if Size_t_size > IVSIZE
2012 PUSHn(retval);
2013#else
2014 PUSHi(retval);
2015#endif
a0d0e21e
LW
2016 RETURN;
2017
2018 say_undef:
a79db61d 2019 Safefree(tmpbuf);
a0d0e21e
LW
2020 SP = ORIGMARK;
2021 RETPUSHUNDEF;
2022}
2023
a0d0e21e
LW
2024PP(pp_eof)
2025{
27da23d5 2026 dVAR; dSP;
a0d0e21e 2027 GV *gv;
32e65323 2028 IO *io;
a5e1d062 2029 const MAGIC *mg;
bc0c81ca
NC
2030 /*
2031 * in Perl 5.12 and later, the additional parameter is a bitmask:
2032 * 0 = eof
2033 * 1 = eof(FH)
2034 * 2 = eof() <- ARGV magic
2035 *
2036 * I'll rely on the compiler's trace flow analysis to decide whether to
2037 * actually assign this out here, or punt it into the only block where it is
2038 * used. Doing it out here is DRY on the condition logic.
2039 */
2040 unsigned int which;
a0d0e21e 2041
bc0c81ca 2042 if (MAXARG) {
32e65323 2043 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
bc0c81ca
NC
2044 which = 1;
2045 }
b5f55170
NC
2046 else {
2047 EXTEND(SP, 1);
2048
bc0c81ca 2049 if (PL_op->op_flags & OPf_SPECIAL) {
b5f55170 2050 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
bc0c81ca
NC
2051 which = 2;
2052 }
2053 else {
b5f55170 2054 gv = PL_last_in_gv; /* eof */
bc0c81ca
NC
2055 which = 0;
2056 }
b5f55170 2057 }
32e65323
CS
2058
2059 if (!gv)
2060 RETPUSHNO;
2061
2062 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
d682515d 2063 return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which));
146174a9 2064 }
4592e6ca 2065
32e65323
CS
2066 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2067 if (io && !IoIFP(io)) {
2068 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2069 IoLINES(io) = 0;
2070 IoFLAGS(io) &= ~IOf_START;
2071 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2072 if (GvSV(gv))
2073 sv_setpvs(GvSV(gv), "-");
2074 else
2075 GvSV(gv) = newSVpvs("-");
2076 SvSETMAGIC(GvSV(gv));
2077 }
2078 else if (!nextargv(gv))
2079 RETPUSHYES;
6136c704 2080 }
4592e6ca
NIS
2081 }
2082
32e65323 2083 PUSHs(boolSV(do_eof(gv)));
a0d0e21e
LW
2084 RETURN;
2085}
2086
2087PP(pp_tell)
2088{
27da23d5 2089 dVAR; dSP; dTARGET;
301e8125 2090 GV *gv;
5b468f54 2091 IO *io;
a0d0e21e 2092
b64a1294 2093 if (MAXARG != 0 && (TOPs || POPs))
159b6efe 2094 PL_last_in_gv = MUTABLE_GV(POPs);
ac3697cd
NC
2095 else
2096 EXTEND(SP, 1);
c4420975 2097 gv = PL_last_in_gv;
4592e6ca 2098
9c9f25b8
NC
2099 io = GvIO(gv);
2100 if (io) {
a5e1d062 2101 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2102 if (mg) {
d682515d 2103 return tied_method0("TELL", SP, MUTABLE_SV(io), mg);
a79db61d 2104 }
4592e6ca 2105 }
f4817f32 2106 else if (!gv) {
f03173f2
RGS
2107 if (!errno)
2108 SETERRNO(EBADF,RMS_IFI);
2109 PUSHi(-1);
2110 RETURN;
2111 }
4592e6ca 2112
146174a9
CB
2113#if LSEEKSIZE > IVSIZE
2114 PUSHn( do_tell(gv) );
2115#else
a0d0e21e 2116 PUSHi( do_tell(gv) );
146174a9 2117#endif
a0d0e21e
LW
2118 RETURN;
2119}
2120
137443ea
PP
2121PP(pp_sysseek)
2122{
27da23d5 2123 dVAR; dSP;
1df70142 2124 const int whence = POPi;
146174a9 2125#if LSEEKSIZE > IVSIZE
7452cf6a 2126 const Off_t offset = (Off_t)SvNVx(POPs);
146174a9 2127#else
7452cf6a 2128 const Off_t offset = (Off_t)SvIVx(POPs);
146174a9 2129#endif
a0d0e21e 2130
159b6efe 2131 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
9c9f25b8 2132 IO *const io = GvIO(gv);
4592e6ca 2133
9c9f25b8 2134 if (io) {
a5e1d062 2135 const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2136 if (mg) {
cb50131a 2137#if LSEEKSIZE > IVSIZE
74f0b550 2138 SV *const offset_sv = newSVnv((NV) offset);
cb50131a 2139#else
74f0b550 2140 SV *const offset_sv = newSViv(offset);
cb50131a 2141#endif
bc0c81ca 2142
d682515d
NC
2143 return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv,
2144 newSViv(whence));
a79db61d 2145 }
4592e6ca
NIS
2146 }
2147
533c011a 2148 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
2149 PUSHs(boolSV(do_seek(gv, offset, whence)));
2150 else {
0bcc34c2 2151 const Off_t sought = do_sysseek(gv, offset, whence);
b448e4fe 2152 if (sought < 0)
146174a9
CB
2153 PUSHs(&PL_sv_undef);
2154 else {
7452cf6a 2155 SV* const sv = sought ?
146174a9 2156#if LSEEKSIZE > IVSIZE
b448e4fe 2157 newSVnv((NV)sought)
146174a9 2158#else
b448e4fe 2159 newSViv(sought)
146174a9
CB
2160#endif
2161 : newSVpvn(zero_but_true, ZBTLEN);
6e449a3a 2162 mPUSHs(sv);
146174a9 2163 }
8903cb82 2164 }
a0d0e21e
LW
2165 RETURN;
2166}
2167
2168PP(pp_truncate)
2169{
97aff369 2170 dVAR;
39644a26 2171 dSP;
8c99d73e
GS
2172 /* There seems to be no consensus on the length type of truncate()
2173 * and ftruncate(), both off_t and size_t have supporters. In
2174 * general one would think that when using large files, off_t is
2175 * at least as wide as size_t, so using an off_t should be okay. */
2176 /* XXX Configure probe for the length type of *truncate() needed XXX */
0bcc34c2 2177 Off_t len;
a0d0e21e 2178
25342a55 2179#if Off_t_size > IVSIZE
0bcc34c2 2180 len = (Off_t)POPn;
8c99d73e 2181#else
0bcc34c2 2182 len = (Off_t)POPi;
8c99d73e
GS
2183#endif
2184 /* Checking for length < 0 is problematic as the type might or
301e8125 2185 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2186 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2187 SETERRNO(0,0);
d05c1ba0 2188 {
5e0adc2d 2189 SV * const sv = POPs;
d05c1ba0
JH
2190 int result = 1;
2191 GV *tmpgv;
090bf15b
SR
2192 IO *io;
2193
5e0adc2d
FC
2194 if ((tmpgv = PL_op->op_flags & OPf_SPECIAL
2195 ? gv_fetchsv(sv, 0, SVt_PVIO)
2196 : MAYBE_DEREF_GV(sv) )) {
9c9f25b8
NC
2197 io = GvIO(tmpgv);
2198 if (!io)
090bf15b 2199 result = 0;
d05c1ba0 2200 else {
090bf15b 2201 PerlIO *fp;
090bf15b
SR
2202 do_ftruncate_io:
2203 TAINT_PROPER("truncate");
2204 if (!(fp = IoIFP(io))) {
2205 result = 0;
2206 }
2207 else {
2208 PerlIO_flush(fp);
cbdc8872 2209#ifdef HAS_TRUNCATE
090bf15b 2210 if (ftruncate(PerlIO_fileno(fp), len) < 0)
301e8125 2211#else
090bf15b 2212 if (my_chsize(PerlIO_fileno(fp), len) < 0)
cbdc8872 2213#endif
090bf15b
SR
2214 result = 0;
2215 }
d05c1ba0 2216 }
cbdc8872 2217 }
5e0adc2d 2218 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2219 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
090bf15b 2220 goto do_ftruncate_io;
5e0adc2d
FC
2221 }
2222 else {
2223 const char * const name = SvPV_nomg_const_nolen(sv);
d05c1ba0 2224 TAINT_PROPER("truncate");
cbdc8872 2225#ifdef HAS_TRUNCATE
d05c1ba0
JH
2226 if (truncate(name, len) < 0)
2227 result = 0;
cbdc8872 2228#else
d05c1ba0 2229 {
7452cf6a 2230 const int tmpfd = PerlLIO_open(name, O_RDWR);
d05c1ba0 2231
7452cf6a 2232 if (tmpfd < 0)
cbdc8872 2233 result = 0;
d05c1ba0
JH
2234 else {
2235 if (my_chsize(tmpfd, len) < 0)
2236 result = 0;
2237 PerlLIO_close(tmpfd);
2238 }
cbdc8872 2239 }
a0d0e21e 2240#endif
d05c1ba0 2241 }
a0d0e21e 2242
d05c1ba0
JH
2243 if (result)
2244 RETPUSHYES;
2245 if (!errno)
93189314 2246 SETERRNO(EBADF,RMS_IFI);
d05c1ba0
JH
2247 RETPUSHUNDEF;
2248 }
a0d0e21e
LW
2249}
2250
a0d0e21e
LW
2251PP(pp_ioctl)
2252{
97aff369 2253 dVAR; dSP; dTARGET;
7452cf6a 2254 SV * const argsv = POPs;
1df70142 2255 const unsigned int func = POPu;
e1ec3a88 2256 const int optype = PL_op->op_type;
159b6efe 2257 GV * const gv = MUTABLE_GV(POPs);
4608196e 2258 IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2259 char *s;
324aa91a 2260 IV retval;
a0d0e21e 2261
748a9306 2262 if (!io || !argsv || !IoIFP(io)) {
51087808 2263 report_evil_fh(gv);
93189314 2264 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
a0d0e21e
LW
2265 RETPUSHUNDEF;
2266 }
2267
748a9306 2268 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2269 STRLEN len;
324aa91a 2270 STRLEN need;
748a9306 2271 s = SvPV_force(argsv, len);
324aa91a
HF
2272 need = IOCPARM_LEN(func);
2273 if (len < need) {
2274 s = Sv_Grow(argsv, need + 1);
2275 SvCUR_set(argsv, need);
a0d0e21e
LW
2276 }
2277
748a9306 2278 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
2279 }
2280 else {
748a9306 2281 retval = SvIV(argsv);
c529f79d 2282 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW
2283 }
2284
ed4b2e6b 2285 TAINT_PROPER(PL_op_desc[optype]);
a0d0e21e
LW
2286
2287 if (optype == OP_IOCTL)
2288#ifdef HAS_IOCTL
76e3520e 2289 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2290#else
cea2e8a9 2291 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW
2292#endif
2293 else
c214f4ad
B
2294#ifndef HAS_FCNTL
2295 DIE(aTHX_ "fcntl is not implemented");
2296#else
55497cff 2297#if defined(OS2) && defined(__EMX__)
760ac839 2298 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2299#else
760ac839 2300 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2301#endif
6652bd42 2302#endif
a0d0e21e 2303
6652bd42 2304#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
748a9306
LW
2305 if (SvPOK(argsv)) {
2306 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2307 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2308 OP_NAME(PL_op));
748a9306
LW
2309 s[SvCUR(argsv)] = 0; /* put our null back */
2310 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
2311 }
2312
2313 if (retval == -1)
2314 RETPUSHUNDEF;
2315 if (retval != 0) {
2316 PUSHi(retval);
2317 }
2318 else {
8903cb82 2319 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2320 }
4808266b 2321#endif
c214f4ad 2322 RETURN;
a0d0e21e
LW
2323}
2324
2325PP(pp_flock)
2326{
9cad6237 2327#ifdef FLOCK
97aff369 2328 dVAR; dSP; dTARGET;
a0d0e21e 2329 I32 value;
7452cf6a 2330 const int argtype = POPi;
159b6efe 2331 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
9c9f25b8
NC
2332 IO *const io = GvIO(gv);
2333 PerlIO *const fp = io ? IoIFP(io) : NULL;
16d20bd9 2334
0bcc34c2 2335 /* XXX Looks to me like io is always NULL at this point */
a0d0e21e 2336 if (fp) {
68dc0745 2337 (void)PerlIO_flush(fp);
76e3520e 2338 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2339 }
cb50131a 2340 else {
51087808 2341 report_evil_fh(gv);
a0d0e21e 2342 value = 0;
93189314 2343 SETERRNO(EBADF,RMS_IFI);
cb50131a 2344 }
a0d0e21e
LW
2345 PUSHi(value);
2346 RETURN;
2347#else
cea2e8a9 2348 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW
2349#endif
2350}
2351
2352/* Sockets. */
2353
7627e6d0
NC
2354#ifdef HAS_SOCKET
2355
a0d0e21e
LW
2356PP(pp_socket)
2357{
97aff369 2358 dVAR; dSP;
7452cf6a
AL
2359 const int protocol = POPi;
2360 const int type = POPi;
2361 const int domain = POPi;
159b6efe 2362 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2363 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e
LW
2364 int fd;
2365
9c9f25b8 2366 if (!io) {
51087808 2367 report_evil_fh(gv);
5ee74a84 2368 if (io && IoIFP(io))
c289d2f7 2369 do_close(gv, FALSE);
93189314 2370 SETERRNO(EBADF,LIB_INVARG);
a0d0e21e
LW
2371 RETPUSHUNDEF;
2372 }
2373
57171420
BS
2374 if (IoIFP(io))
2375 do_close(gv, FALSE);
2376
a0d0e21e 2377 TAINT_PROPER("socket");
6ad3d225 2378 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW
2379 if (fd < 0)
2380 RETPUSHUNDEF;
460c8493
IZ
2381 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2382 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2383 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2384 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
2385 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2386 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2387 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
2388 RETPUSHUNDEF;
2389 }
8d2a6795
GS
2390#if defined(HAS_FCNTL) && defined(F_SETFD)
2391 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2392#endif
a0d0e21e 2393
d5ff79b3
OF
2394#ifdef EPOC
2395 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2396#endif
2397
a0d0e21e 2398 RETPUSHYES;
a0d0e21e 2399}
7627e6d0 2400#endif
a0d0e21e
LW
2401
2402PP(pp_sockpair)
2403{
c95c94b1 2404#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
97aff369 2405 dVAR; dSP;
7452cf6a
AL
2406 const int protocol = POPi;
2407 const int type = POPi;
2408 const int domain = POPi;
159b6efe
NC
2409 GV * const gv2 = MUTABLE_GV(POPs);
2410 GV * const gv1 = MUTABLE_GV(POPs);
7452cf6a
AL
2411 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2412 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
a0d0e21e
LW
2413 int fd[2];
2414
9c9f25b8
NC
2415 if (!io1)
2416 report_evil_fh(gv1);
2417 if (!io2)
2418 report_evil_fh(gv2);
a0d0e21e 2419
46d2cc54 2420 if (io1 && IoIFP(io1))
dc0d0a5f 2421 do_close(gv1, FALSE);
46d2cc54 2422 if (io2 && IoIFP(io2))
dc0d0a5f 2423 do_close(gv2, FALSE);
57171420 2424
46d2cc54
NC
2425 if (!io1 || !io2)
2426 RETPUSHUNDEF;
2427
a0d0e21e 2428 TAINT_PROPER("socketpair");
6ad3d225 2429 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2430 RETPUSHUNDEF;
460c8493
IZ
2431 IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2432 IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
50952442 2433 IoTYPE(io1) = IoTYPE_SOCKET;
460c8493
IZ
2434 IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2435 IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
50952442 2436 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2437 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW
2438 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2439 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2440 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW
2441 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2442 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2443 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW
2444 RETPUSHUNDEF;
2445 }
8d2a6795
GS
2446#if defined(HAS_FCNTL) && defined(F_SETFD)
2447 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2448 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2449#endif
a0d0e21e
LW
2450
2451 RETPUSHYES;
2452#else
cea2e8a9 2453 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW
2454#endif
2455}
2456
7627e6d0
NC
2457#ifdef HAS_SOCKET
2458
a0d0e21e
LW
2459PP(pp_bind)
2460{
97aff369 2461 dVAR; dSP;
7452cf6a 2462 SV * const addrsv = POPs;
349d4f2f
NC
2463 /* OK, so on what platform does bind modify addr? */
2464 const char *addr;
159b6efe 2465 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2466 register IO * const io = GvIOn(gv);
a0d0e21e 2467 STRLEN len;
32b81f04 2468 const int op_type = PL_op->op_type;
a0d0e21e
LW
2469
2470 if (!io || !IoIFP(io))
2471 goto nuts;
2472
349d4f2f 2473 addr = SvPV_const(addrsv, len);
32b81f04
NC
2474 TAINT_PROPER(PL_op_desc[op_type]);
2475 if ((op_type == OP_BIND
2476 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2477 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2478 >= 0)
a0d0e21e
LW
2479 RETPUSHYES;
2480 else
2481 RETPUSHUNDEF;
2482
2483nuts:
fbcda526 2484 report_evil_fh(gv);
93189314 2485 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2486 RETPUSHUNDEF;
a0d0e21e
LW
2487}
2488
2489PP(pp_listen)
2490{
97aff369 2491 dVAR; dSP;
7452cf6a 2492 const int backlog = POPi;
159b6efe 2493 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2494 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2495
9c9f25b8 2496 if (!io || !IoIFP(io))
a0d0e21e
LW
2497 goto nuts;
2498
6ad3d225 2499 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW
2500 RETPUSHYES;
2501 else
2502 RETPUSHUNDEF;
2503
2504nuts:
fbcda526 2505 report_evil_fh(gv);
93189314 2506 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2507 RETPUSHUNDEF;
a0d0e21e
LW
2508}
2509
2510PP(pp_accept)
2511{
97aff369 2512 dVAR; dSP; dTARGET;
a0d0e21e
LW
2513 register IO *nstio;
2514 register IO *gstio;
93d47a36
JH
2515 char namebuf[MAXPATHLEN];
2516#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
2517 Sock_size_t len = sizeof (struct sockaddr_in);
2518#else
2519 Sock_size_t len = sizeof namebuf;
2520#endif
159b6efe
NC
2521 GV * const ggv = MUTABLE_GV(POPs);
2522 GV * const ngv = MUTABLE_GV(POPs);
a0d0e21e
LW
2523 int fd;
2524
a0d0e21e
LW
2525 if (!ngv)
2526 goto badexit;
2527 if (!ggv)
2528 goto nuts;
2529
2530 gstio = GvIO(ggv);
2531 if (!gstio || !IoIFP(gstio))
2532 goto nuts;
2533
2534 nstio = GvIOn(ngv);
93d47a36 2535 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
e294cc5d
JH
2536#if defined(OEMVS)
2537 if (len == 0) {
2538 /* Some platforms indicate zero length when an AF_UNIX client is
2539 * not bound. Simulate a non-zero-length sockaddr structure in
2540 * this case. */
2541 namebuf[0] = 0; /* sun_len */
2542 namebuf[1] = AF_UNIX; /* sun_family */
2543 len = 2;
2544 }
2545#endif
2546
a0d0e21e
LW
2547 if (fd < 0)
2548 goto badexit;
a70048fb
AB
2549 if (IoIFP(nstio))
2550 do_close(ngv, FALSE);
460c8493
IZ
2551 IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2552 IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2553 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2554 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW
2555 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2556 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2557 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW
2558 goto badexit;
2559 }
8d2a6795
GS
2560#if defined(HAS_FCNTL) && defined(F_SETFD)
2561 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2562#endif
a0d0e21e 2563
ed79a026 2564#ifdef EPOC
93d47a36 2565 len = sizeof (struct sockaddr_in); /* EPOC somehow truncates info */
a9f1f6b0 2566 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026 2567#endif
381c1bae 2568#ifdef __SCO_VERSION__
93d47a36 2569 len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
381c1bae 2570#endif
ed79a026 2571
93d47a36 2572 PUSHp(namebuf, len);
a0d0e21e
LW
2573 RETURN;
2574
2575nuts:
fbcda526 2576 report_evil_fh(ggv);
93189314 2577 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW
2578
2579badexit:
2580 RETPUSHUNDEF;
2581
a0d0e21e
LW
2582}
2583
2584PP(pp_shutdown)
2585{
97aff369 2586 dVAR; dSP; dTARGET;
7452cf6a 2587 const int how = POPi;
159b6efe 2588 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2589 register IO * const io = GvIOn(gv);
a0d0e21e
LW
2590
2591 if (!io || !IoIFP(io))
2592 goto nuts;
2593
6ad3d225 2594 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW
2595 RETURN;
2596
2597nuts:
fbcda526 2598 report_evil_fh(gv);
93189314 2599 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e 2600 RETPUSHUNDEF;
a0d0e21e
LW
2601}
2602
a0d0e21e
LW
2603PP(pp_ssockopt)
2604{
97aff369 2605 dVAR; dSP;
7452cf6a 2606 const int optype = PL_op->op_type;
561b68a9 2607 SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
7452cf6a
AL
2608 const unsigned int optname = (unsigned int) POPi;
2609 const unsigned int lvl = (unsigned int) POPi;
159b6efe 2610 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2611 register IO * const io = GvIOn(gv);
a0d0e21e 2612 int fd;
1e422769 2613 Sock_size_t len;
a0d0e21e 2614
a0d0e21e
LW
2615 if (!io || !IoIFP(io))
2616 goto nuts;
2617
760ac839 2618 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2619 switch (optype) {
2620 case OP_GSOCKOPT:
748a9306 2621 SvGROW(sv, 257);
a0d0e21e 2622 (void)SvPOK_only(sv);
748a9306
LW
2623 SvCUR_set(sv,256);
2624 *SvEND(sv) ='\0';
1e422769 2625 len = SvCUR(sv);
6ad3d225 2626 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2627 goto nuts2;
1e422769 2628 SvCUR_set(sv, len);
748a9306 2629 *SvEND(sv) ='\0';
a0d0e21e
LW
2630 PUSHs(sv);
2631 break;
2632 case OP_SSOCKOPT: {
1215b447
JH
2633#if defined(__SYMBIAN32__)
2634# define SETSOCKOPT_OPTION_VALUE_T void *
2635#else
2636# define SETSOCKOPT_OPTION_VALUE_T const char *
2637#endif
2638 /* XXX TODO: We need to have a proper type (a Configure probe,
2639 * etc.) for what the C headers think of the third argument of
2640 * setsockopt(), the option_value read-only buffer: is it
2641 * a "char *", or a "void *", const or not. Some compilers
2642 * don't take kindly to e.g. assuming that "char *" implicitly
2643 * promotes to a "void *", or to explicitly promoting/demoting
2644 * consts to non/vice versa. The "const void *" is the SUS
2645 * definition, but that does not fly everywhere for the above
2646 * reasons. */
2647 SETSOCKOPT_OPTION_VALUE_T buf;
1e422769
PP
2648 int aint;
2649 if (SvPOKp(sv)) {
2d8e6c8d 2650 STRLEN l;
1215b447 2651 buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2d8e6c8d 2652 len = l;
1e422769 2653 }
56ee1660 2654 else {
a0d0e21e 2655 aint = (int)SvIV(sv);
1215b447 2656 buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
a0d0e21e
LW
2657 len = sizeof(int);
2658 }
6ad3d225 2659 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2660 goto nuts2;
3280af22 2661 PUSHs(&PL_sv_yes);
a0d0e21e
LW
2662 }
2663 break;
2664 }
2665 RETURN;
2666
2667nuts:
fbcda526 2668 report_evil_fh(gv);
93189314 2669 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW
2670nuts2:
2671 RETPUSHUNDEF;
2672
a0d0e21e
LW
2673}
2674
a0d0e21e
LW
2675PP(pp_getpeername)
2676{
97aff369 2677 dVAR; dSP;
7452cf6a 2678 const int optype = PL_op->op_type;
159b6efe 2679 GV * const gv = MUTABLE_GV(POPs);
7452cf6a
AL
2680 register IO * const io = GvIOn(gv);
2681 Sock_size_t len;
a0d0e21e
LW
2682 SV *sv;
2683 int fd;
a0d0e21e
LW
2684
2685 if (!io || !IoIFP(io))
2686 goto nuts;
2687
561b68a9 2688 sv = sv_2mortal(newSV(257));
748a9306 2689 (void)SvPOK_only(sv);
1e422769
PP
2690 len = 256;
2691 SvCUR_set(sv, len);
748a9306 2692 *SvEND(sv) ='\0';
760ac839 2693 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW
2694 switch (optype) {
2695 case OP_GETSOCKNAME:
6ad3d225 2696 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW
2697 goto nuts2;
2698 break;
2699 case OP_GETPEERNAME:
6ad3d225 2700 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2701 goto nuts2;
490ab354
JH
2702#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2703 {
2704 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";
2705 /* If the call succeeded, make sure we don't have a zeroed port/addr */
349d4f2f 2706 if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2fbb330f 2707 !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
490ab354 2708 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2709 goto nuts2;
490ab354
JH
2710 }
2711 }
2712#endif
a0d0e21e
LW
2713 break;
2714 }
13826f2c
CS
2715#ifdef BOGUS_GETNAME_RETURN
2716 /* Interactive Unix, getpeername() and getsockname()
2717 does not return valid namelen */
1e422769
PP
2718 if (len == BOGUS_GETNAME_RETURN)
2719 len = sizeof(struct sockaddr);
13826f2c 2720#endif
1e422769 2721 SvCUR_set(sv, len);
748a9306 2722 *SvEND(sv) ='\0';
a0d0e21e
LW
2723 PUSHs(sv);
2724 RETURN;
2725
2726nuts:
fbcda526 2727 report_evil_fh(gv);
93189314 2728 SETERRNO(EBADF,SS_IVCHAN);
a0d0e21e
LW
2729nuts2:
2730 RETPUSHUNDEF;
7627e6d0 2731}
a0d0e21e 2732
a0d0e21e 2733#endif
a0d0e21e
LW
2734
2735/* Stat calls. */
2736
a0d0e21e
LW
2737PP(pp_stat)
2738{
97aff369 2739 dVAR;
39644a26 2740 dSP;
10edeb5d 2741 GV *gv = NULL;
ad02613c 2742 IO *io;
54310121 2743 I32 gimme;
a0d0e21e 2744 I32 max = 13;
109c43ed 2745 SV* sv;
a0d0e21e 2746
109c43ed
FC
2747 if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
2748 : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
8a4e5b40 2749 if (PL_op->op_type == OP_LSTAT) {
5d3e98de 2750 if (gv != PL_defgv) {
5d329e6e 2751 do_fstat_warning_check:
a2a5de95 2752 Perl_ck_warner(aTHX_ packWARN(WARN_IO),
bf29d05f
BF
2753 "lstat() on filehandle %"SVf, SVfARG(gv
2754 ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2755 : &PL_sv_no));
5d3e98de 2756 } else if (PL_laststype != OP_LSTAT)
b042df57 2757 /* diag_listed_as: The stat preceding %s wasn't an lstat */
8a4e5b40 2758 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
8a4e5b40
DD
2759 }
2760
2dd78f96 2761 if (gv != PL_defgv) {
3280af22 2762 PL_laststype = OP_STAT;
2dd78f96 2763 PL_statgv = gv;
76f68e9b 2764 sv_setpvs(PL_statname, "");
5228a96c 2765 if(gv) {
ad02613c
SP
2766 io = GvIO(gv);
2767 do_fstat_have_io:
5228a96c
SP
2768 if (io) {
2769 if (IoIFP(io)) {
2770 PL_laststatval =
2771 PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2772 } else if (IoDIRP(io)) {
5228a96c 2773 PL_laststatval =
3497a01f 2774 PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
5228a96c
SP
2775 } else {
2776 PL_laststatval = -1;
2777 }
2778 }
2779 }
2780 }
2781
9ddeeac9 2782 if (PL_laststatval < 0) {
51087808 2783 report_evil_fh(gv);
a0d0e21e 2784 max = 0;
9ddeeac9 2785 }
a0d0e21e
LW
2786 }
2787 else {
109c43ed 2788 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2789 io = MUTABLE_IO(SvRV(sv));
ad02613c
SP
2790 if (PL_op->op_type == OP_LSTAT)
2791 goto do_fstat_warning_check;
2792 goto do_fstat_have_io;
2793 }
2794
109c43ed 2795 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
a0714e2c 2796 PL_statgv = NULL;
533c011a
NIS
2797 PL_laststype = PL_op->op_type;
2798 if (PL_op->op_type == OP_LSTAT)
0510663f 2799 PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
a0d0e21e 2800 else
0510663f 2801 PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
3280af22 2802 if (PL_laststatval < 0) {
0510663f 2803 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
9014280d 2804 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
a0d0e21e
LW
2805 max = 0;
2806 }
2807 }
2808
54310121
PP
2809 gimme = GIMME_V;
2810 if (gimme != G_ARRAY) {
2811 if (gimme != G_VOID)
2812 XPUSHs(boolSV(max));
2813 RETURN;
a0d0e21e
LW
2814 }
2815 if (max) {
36477c24
PP
2816 EXTEND(SP, max);
2817 EXTEND_MORTAL(max);
6e449a3a 2818 mPUSHi(PL_statcache.st_dev);
8d8cba88
TC
2819#if ST_INO_SIZE > IVSIZE
2820 mPUSHn(PL_statcache.st_ino);
2821#else
2822# if ST_INO_SIGN <= 0
6e449a3a 2823 mPUSHi(PL_statcache.st_ino);
8d8cba88
TC
2824# else
2825 mPUSHu(PL_statcache.st_ino);
2826# endif
2827#endif
6e449a3a
MHM
2828 mPUSHu(PL_statcache.st_mode);
2829 mPUSHu(PL_statcache.st_nlink);
146174a9 2830#if Uid_t_size > IVSIZE
6e449a3a 2831 mPUSHn(PL_statcache.st_uid);
146174a9 2832#else
23dcd6c8 2833# if Uid_t_sign <= 0
6e449a3a 2834 mPUSHi(PL_statcache.st_uid);
23dcd6c8 2835# else
6e449a3a 2836 mPUSHu(PL_statcache.st_uid);
23dcd6c8 2837# endif
146174a9 2838#endif
301e8125 2839#if Gid_t_size > IVSIZE
6e449a3a 2840 mPUSHn(PL_statcache.st_gid);
146174a9 2841#else
23dcd6c8 2842# if Gid_t_sign <= 0
6e449a3a 2843 mPUSHi(PL_statcache.st_gid);
23dcd6c8 2844# else
6e449a3a 2845 mPUSHu(PL_statcache.st_gid);
23dcd6c8 2846# endif
146174a9 2847#endif
cbdc8872 2848#ifdef USE_STAT_RDEV
6e449a3a 2849 mPUSHi(PL_statcache.st_rdev);
cbdc8872 2850#else
84bafc02 2851 PUSHs(newSVpvs_flags("", SVs_TEMP));
cbdc8872 2852#endif
146174a9 2853#if Off_t_size > IVSIZE
6e449a3a 2854 mPUSHn(PL_statcache.st_size);
146174a9 2855#else
6e449a3a 2856 mPUSHi(PL_statcache.st_size);
146174a9 2857#endif
cbdc8872 2858#ifdef BIG_TIME
6e449a3a
MHM
2859 mPUSHn(PL_statcache.st_atime);
2860 mPUSHn(PL_statcache.st_mtime);
2861 mPUSHn(PL_statcache.st_ctime);
cbdc8872 2862#else
6e449a3a
MHM
2863 mPUSHi(PL_statcache.st_atime);
2864 mPUSHi(PL_statcache.st_mtime);
2865 mPUSHi(PL_statcache.st_ctime);
cbdc8872 2866#endif
a0d0e21e 2867#ifdef USE_STAT_BLOCKS
6e449a3a
MHM
2868 mPUSHu(PL_statcache.st_blksize);
2869 mPUSHu(PL_statcache.st_blocks);
a0d0e21e 2870#else
84bafc02
NC
2871 PUSHs(newSVpvs_flags("", SVs_TEMP));
2872 PUSHs(newSVpvs_flags("", SVs_TEMP));
a0d0e21e
LW
2873#endif
2874 }
2875 RETURN;
2876}
2877
6f1401dc
DM
2878#define tryAMAGICftest_MG(chr) STMT_START { \
2879 if ( (SvFLAGS(TOPs) & (SVf_ROK|SVs_GMG)) \
49498caf 2880 && PL_op->op_flags & OPf_KIDS \
6f1401dc
DM
2881 && S_try_amagic_ftest(aTHX_ chr)) \
2882 return NORMAL; \
2883 } STMT_END
2884
2885STATIC bool
2886S_try_amagic_ftest(pTHX_ char chr) {
2887 dVAR;
2888 dSP;
2889 SV* const arg = TOPs;
2890
2891 assert(chr != '?');
2892 SvGETMAGIC(arg);
2893
49498caf 2894 if (SvAMAGIC(TOPs))
6f1401dc
DM
2895 {
2896 const char tmpchr = chr;
6f1401dc
DM
2897 SV * const tmpsv = amagic_call(arg,
2898 newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2899 ftest_amg, AMGf_unary);
2900
2901 if (!tmpsv)
2902 return FALSE;
2903
2904 SPAGAIN;
2905
bbd91306 2906 if (PL_op->op_private & OPpFT_STACKING) {
6f1401dc
DM
2907 if (SvTRUE(tmpsv))
2908 /* leave the object alone */
2909 return TRUE;
2910 }
2911
2912 SETs(tmpsv);
2913 PUTBACK;
2914 return TRUE;
2915 }
2916 return FALSE;
2917}
2918
2919
fbb0b3b3
RGS
2920/* This macro is used by the stacked filetest operators :
2921 * if the previous filetest failed, short-circuit and pass its value.
2922 * Else, discard it from the stack and continue. --rgs
2923 */
2924#define STACKED_FTEST_CHECK if (PL_op->op_private & OPpFT_STACKED) { \
d724f706 2925 if (!SvTRUE(TOPs)) { RETURN; } \
fbb0b3b3
RGS
2926 else { (void)POPs; PUTBACK; } \
2927 }
2928
a0d0e21e
LW
2929PP(pp_ftrread)
2930{
97aff369 2931 dVAR;
9cad6237 2932 I32 result;
af9e49b4
NC
2933 /* Not const, because things tweak this below. Not bool, because there's
2934 no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2935#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2936 I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2937 /* Giving some sort of initial value silences compilers. */
2938# ifdef R_OK
2939 int access_mode = R_OK;
2940# else
2941 int access_mode = 0;
2942# endif
5ff3f7a4 2943#else
af9e49b4
NC
2944 /* access_mode is never used, but leaving use_access in makes the
2945 conditional compiling below much clearer. */
2946 I32 use_access = 0;
5ff3f7a4 2947#endif
2dcac756 2948 Mode_t stat_mode = S_IRUSR;
a0d0e21e 2949
af9e49b4 2950 bool effective = FALSE;
07fe7c6a 2951 char opchar = '?';
2a3ff820 2952 dSP;
af9e49b4 2953
7fb13887
BM
2954 switch (PL_op->op_type) {
2955 case OP_FTRREAD: opchar = 'R'; break;
2956 case OP_FTRWRITE: opchar = 'W'; break;
2957 case OP_FTREXEC: opchar = 'X'; break;
2958 case OP_FTEREAD: opchar = 'r'; break;
2959 case OP_FTEWRITE: opchar = 'w'; break;
2960 case OP_FTEEXEC: opchar = 'x'; break;
2961 }
6f1401dc 2962 tryAMAGICftest_MG(opchar);
7fb13887 2963
fbb0b3b3 2964 STACKED_FTEST_CHECK;
af9e49b4
NC
2965
2966 switch (PL_op->op_type) {
2967 case OP_FTRREAD:
2968#if !(defined(HAS_ACCESS) && defined(R_OK))
2969 use_access = 0;
2970#endif
2971 break;
2972
2973 case OP_FTRWRITE:
5ff3f7a4 2974#if defined(HAS_ACCESS) && defined(W_OK)
af9e49b4 2975 access_mode = W_OK;
5ff3f7a4 2976#else
af9e49b4 2977 use_access = 0;
5ff3f7a4 2978#endif
af9e49b4
NC
2979 stat_mode = S_IWUSR;
2980 break;
a0d0e21e 2981
af9e49b4 2982 case OP_FTREXEC:
5ff3f7a4 2983#if defined(HAS_ACCESS) && defined(X_OK)
af9e49b4 2984 access_mode = X_OK;
5ff3f7a4 2985#else
af9e49b4 2986 use_access = 0;
5ff3f7a4 2987#endif
af9e49b4
NC
2988 stat_mode = S_IXUSR;
2989 break;
a0d0e21e 2990
af9e49b4 2991 case OP_FTEWRITE:
faee0e31 2992#ifdef PERL_EFF_ACCESS
af9e49b4 2993 access_mode = W_OK;
5ff3f7a4 2994#endif
af9e49b4 2995 stat_mode = S_IWUSR;
7fb13887 2996 /* fall through */
a0d0e21e 2997
af9e49b4
NC
2998 case OP_FTEREAD:
2999#ifndef PERL_EFF_ACCESS
3000 use_access = 0;
3001#endif
3002 effective = TRUE;
3003 break;
3004
af9e49b4 3005 case OP_FTEEXEC:
faee0e31 3006#ifdef PERL_EFF_ACCESS
b376053d 3007 access_mode = X_OK;
5ff3f7a4 3008#else
af9e49b4 3009 use_access = 0;
5ff3f7a4 3010#endif
af9e49b4
NC
3011 stat_mode = S_IXUSR;
3012 effective = TRUE;
3013 break;
3014 }
a0d0e21e 3015
af9e49b4
NC
3016 if (use_access) {
3017#if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2c2f35ab 3018 const char *name = POPpx;
af9e49b4
NC
3019 if (effective) {
3020# ifdef PERL_EFF_ACCESS
3021 result = PERL_EFF_ACCESS(name, access_mode);
3022# else
3023 DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3024 OP_NAME(PL_op));
3025# endif
3026 }
3027 else {
3028# ifdef HAS_ACCESS
3029 result = access(name, access_mode);
3030# else
3031 DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3032# endif
3033 }
5ff3f7a4
GS
3034 if (result == 0)
3035 RETPUSHYES;
3036 if (result < 0)
3037 RETPUSHUNDEF;
3038 RETPUSHNO;
af9e49b4 3039#endif
22865c03 3040 }
af9e49b4 3041
40c852de 3042 result = my_stat_flags(0);
22865c03 3043 SPAGAIN;
a0d0e21e
LW
3044 if (result < 0)
3045 RETPUSHUNDEF;
af9e49b4 3046 if (cando(stat_mode, effective, &PL_statcache))
a0d0e21e
LW
3047 RETPUSHYES;
3048 RETPUSHNO;
3049}
3050
3051PP(pp_ftis)
3052{
97aff369 3053 dVAR;
fbb0b3b3 3054 I32 result;
d7f0a2f4 3055 const int op_type = PL_op->op_type;
07fe7c6a 3056 char opchar = '?';
2a3ff820 3057 dSP;
07fe7c6a
BM
3058
3059 switch (op_type) {
3060 case OP_FTIS: opchar = 'e'; break;
3061 case OP_FTSIZE: opchar = 's'; break;
3062 case OP_FTMTIME: opchar = 'M'; break;
3063 case OP_FTCTIME: opchar = 'C'; break;
3064 case OP_FTATIME: opchar = 'A'; break;
3065 }
6f1401dc 3066 tryAMAGICftest_MG(opchar);
07fe7c6a 3067
fbb0b3b3 3068 STACKED_FTEST_CHECK;
7fb13887 3069
40c852de 3070 result = my_stat_flags(0);
fbb0b3b3 3071 SPAGAIN;
a0d0e21e
LW
3072 if (result < 0)
3073 RETPUSHUNDEF;
d7f0a2f4
NC
3074 if (op_type == OP_FTIS)
3075 RETPUSHYES;
957b0e1d 3076 {
d7f0a2f4
NC
3077 /* You can't dTARGET inside OP_FTIS, because you'll get
3078 "panic: pad_sv po" - the op is not flagged to have a target. */
957b0e1d 3079 dTARGET;
d7f0a2f4 3080 switch (op_type) {
957b0e1d
NC
3081 case OP_FTSIZE:
3082#if Off_t_size > IVSIZE
3083 PUSHn(PL_statcache.st_size);
3084#else
3085 PUSHi(PL_statcache.st_size);
3086#endif
3087 break;
3088 case OP_FTMTIME:
3089 PUSHn( (((NV)PL_basetime - PL_statcache.st_mtime)) / 86400.0 );
3090 break;
3091 case OP_FTATIME:
3092 PUSHn( (((NV)PL_basetime - PL_statcache.st_atime)) / 86400.0 );
3093 break;
3094 case OP_FTCTIME:
3095 PUSHn( (((NV)PL_basetime - PL_statcache.st_ctime)) / 86400.0 );
3096 break;
3097 }
3098 }
3099 RETURN;
a0d0e21e
LW
3100}
3101
a0d0e21e
LW
3102PP(pp_ftrowned)
3103{
97aff369 3104 dVAR;
fbb0b3b3 3105 I32 result;
07fe7c6a 3106 char opchar = '?';
2a3ff820 3107 dSP;
17ad201a 3108
7fb13887
BM
3109 switch (PL_op->op_type) {
3110 case OP_FTROWNED: opchar = 'O'; break;
3111 case OP_FTEOWNED: opchar = 'o'; break;
3112 case OP_FTZERO: opchar = 'z'; break;
3113 case OP_FTSOCK: opchar = 'S'; break;
3114 case OP_FTCHR: opchar = 'c'; break;
3115 case OP_FTBLK: opchar = 'b'; break;
3116 case OP_FTFILE: opchar = 'f'; break;
3117 case OP_FTDIR: opchar = 'd'; break;
3118 case OP_FTPIPE: opchar = 'p'; break;
3119 case OP_FTSUID: opchar = 'u'; break;
3120 case OP_FTSGID: opchar = 'g'; break;
3121 case OP_FTSVTX: opchar = 'k'; break;
3122 }
6f1401dc 3123 tryAMAGICftest_MG(opchar);
7fb13887 3124
1b0124a7
JD
3125 STACKED_FTEST_CHECK;
3126
17ad201a
NC
3127 /* I believe that all these three are likely to be defined on most every
3128 system these days. */
3129#ifndef S_ISUID
c410dd6a 3130 if(PL_op->op_type == OP_FTSUID) {
1b0124a7
JD
3131 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3132 (void) POPs;
17ad201a 3133 RETPUSHNO;
c410dd6a 3134 }
17ad201a
NC
3135#endif
3136#ifndef S_ISGID
c410dd6a 3137 if(PL_op->op_type == OP_FTSGID) {
1b0124a7
JD
3138 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3139 (void) POPs;
17ad201a 3140 RETPUSHNO;
c410dd6a 3141 }
17ad201a
NC
3142#endif
3143#ifndef S_ISVTX
c410dd6a 3144 if(PL_op->op_type == OP_FTSVTX) {
1b0124a7
JD
3145 if ((PL_op->op_flags & OPf_REF) == 0 && (PL_op->op_private & OPpFT_STACKED) == 0)
3146 (void) POPs;
17ad201a 3147 RETPUSHNO;
c410dd6a 3148 }
17ad201a
NC
3149#endif
3150
40c852de 3151 result = my_stat_flags(0);
fbb0b3b3 3152 SPAGAIN;
a0d0e21e
LW
3153 if (result < 0)
3154 RETPUSHUNDEF;
f1cb2d48
NC
3155 switch (PL_op->op_type) {
3156 case OP_FTROWNED:
9ab9fa88 3157 if (PL_statcache.st_uid == PL_uid)
f1cb2d48
NC
3158 RETPUSHYES;
3159 break;
3160 case OP_FTEOWNED:
3161 if (PL_statcache.st_uid == PL_euid)
3162 RETPUSHYES;
3163 break;
3164 case OP_FTZERO:
3165 if (PL_statcache.st_size == 0)
3166 RETPUSHYES;
3167 break;
3168 case OP_FTSOCK:
3169 if (S_ISSOCK(PL_statcache.st_mode))
3170 RETPUSHYES;
3171 break;
3172 case OP_FTCHR:
3173 if (S_ISCHR(PL_statcache.st_mode))
3174 RETPUSHYES;
3175 break;
3176 case OP_FTBLK:
3177 if (S_ISBLK(PL_statcache.st_mode))
3178 RETPUSHYES;
3179 break;
3180 case OP_FTFILE:
3181 if (S_ISREG(PL_statcache.st_mode))
3182 RETPUSHYES;
3183 break;
3184 case OP_FTDIR:
3185 if (S_ISDIR(PL_statcache.st_mode))
3186 RETPUSHYES;
3187 break;
3188 case OP_FTPIPE:
3189 if (S_ISFIFO(PL_statcache.st_mode))
3190 RETPUSHYES;
3191 break;
a0d0e21e 3192#ifdef S_ISUID
17ad201a
NC
3193 case OP_FTSUID:
3194 if (PL_statcache.st_mode & S_ISUID)
3195 RETPUSHYES;
3196 break;
a0d0e21e 3197#endif
a0d0e21e 3198#ifdef S_ISGID
17ad201a
NC
3199 case OP_FTSGID:
3200 if (PL_statcache.st_mode & S_ISGID)
3201 RETPUSHYES;
3202 break;
3203#endif
3204#ifdef S_ISVTX
3205 case OP_FTSVTX:
3206 if (PL_statcache.st_mode & S_ISVTX)
3207 RETPUSHYES;
3208 break;
a0d0e21e 3209#endif
17ad201a 3210 }
a0d0e21e
LW
3211 RETPUSHNO;
3212}
3213
17ad201a 3214PP(pp_ftlink)
a0d0e21e 3215{
97aff369 3216 dVAR;
39644a26 3217 dSP;
500ff13f 3218 I32 result;
07fe7c6a 3219
6f1401dc 3220 tryAMAGICftest_MG('l');
1f26655e 3221 STACKED_FTEST_CHECK;
40c852de 3222 result = my_lstat_flags(0);
500ff13f
BM
3223 SPAGAIN;
3224
a0d0e21e
LW
3225 if (result < 0)
3226 RETPUSHUNDEF;
17ad201a 3227 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e 3228 RETPUSHYES;
a0d0e21e
LW
3229 RETPUSHNO;
3230}
3231
3232PP(pp_fttty)
3233{
97aff369 3234 dVAR;
39644a26 3235 dSP;
a0d0e21e
LW
3236 int fd;
3237 GV *gv;
a0714e2c 3238 SV *tmpsv = NULL;
0784aae0 3239 char *name = NULL;
40c852de 3240 STRLEN namelen;
fb73857a 3241
6f1401dc 3242 tryAMAGICftest_MG('t');
07fe7c6a 3243
fbb0b3b3
RGS
3244 STACKED_FTEST_CHECK;
3245
533c011a 3246 if (PL_op->op_flags & OPf_REF)
146174a9 3247 gv = cGVOP_gv;
094a3eec 3248 else if (!(gv = MAYBE_DEREF_GV_nomg(TOPs))) {
40c852de
DM
3249 tmpsv = POPs;
3250 name = SvPV_nomg(tmpsv, namelen);
3251 gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3252 }
fb73857a 3253
a0d0e21e 3254 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3255 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
7a5fd60d 3256 else if (tmpsv && SvOK(tmpsv)) {
40c852de
DM
3257 if (isDIGIT(*name))
3258 fd = atoi(name);
7a5fd60d
NC
3259 else
3260 RETPUSHUNDEF;
3261 }
a0d0e21e
LW
3262 else
3263 RETPUSHUNDEF;
6ad3d225 3264 if (PerlLIO_isatty(fd))
a0d0e21e
LW
3265 RETPUSHYES;
3266 RETPUSHNO;
3267}
3268
16d20bd9
AD
3269#if defined(atarist) /* this will work with atariST. Configure will
3270 make guesses for other systems. */
3271# define FILE_base(f) ((f)->_base)
3272# define FILE_ptr(f) ((f)->_ptr)
3273# define FILE_cnt(f) ((f)->_cnt)
3274# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW
3275#endif
3276
3277PP(pp_fttext)
3278{
97aff369 3279 dVAR;
39644a26 3280 dSP;
a0d0e21e
LW
3281 I32 i;
3282 I32 len;
3283 I32 odd = 0;
3284 STDCHAR tbuf[512];
3285 register STDCHAR *s;
3286 register IO *io;
5f05dabc
PP
3287 register SV *sv;
3288 GV *gv;
146174a9 3289 PerlIO *fp;
a0d0e21e 3290
6f1401dc 3291 tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
07fe7c6a 3292
fbb0b3b3
RGS
3293 STACKED_FTEST_CHECK;
3294
533c011a 3295 if (PL_op->op_flags & OPf_REF)
146174a9 3296 gv = cGVOP_gv;
094a3eec 3297 else gv = MAYBE_DEREF_GV_nomg(TOPs);
5f05dabc
PP
3298
3299 if (gv) {
a0d0e21e 3300 EXTEND(SP, 1);
3280af22
NIS
3301 if (gv == PL_defgv) {
3302 if (PL_statgv)
3303 io = GvIO(PL_statgv);
a0d0e21e 3304 else {
3280af22 3305 sv = PL_statname;
a0d0e21e
LW
3306 goto really_filename;
3307 }
3308 }
3309 else {
3280af22
NIS
3310 PL_statgv = gv;
3311 PL_laststatval = -1;
76f68e9b 3312 sv_setpvs(PL_statname, "");
3280af22 3313 io = GvIO(PL_statgv);
a0d0e21e
LW
3314 }
3315 if (io && IoIFP(io)) {
5f05dabc 3316 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3317 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS
3318 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3319 if (PL_laststatval < 0)
5f05dabc 3320 RETPUSHUNDEF;
9cbac4c7 3321 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3322 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3323 RETPUSHNO;
3324 else
3325 RETPUSHYES;
9cbac4c7 3326 }
a20bf0c3 3327 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3328 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3329 if (i != EOF)
760ac839 3330 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3331 }
a20bf0c3 3332 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3333 RETPUSHYES;
a20bf0c3
JH
3334 len = PerlIO_get_bufsiz(IoIFP(io));
3335 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW
3336 /* sfio can have large buffers - limit to 512 */
3337 if (len > 512)
3338 len = 512;
a0d0e21e
LW
3339 }
3340 else {
51087808 3341 report_evil_fh(cGVOP_gv);
93189314 3342 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
3343 RETPUSHUNDEF;
3344 }
3345 }
3346 else {
3347 sv = POPs;
5f05dabc 3348 really_filename:
a0714e2c 3349 PL_statgv = NULL;
5c9aa243 3350 PL_laststype = OP_STAT;
40c852de 3351 sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
aa07b2f6 3352 if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
349d4f2f
NC
3353 if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
3354 '\n'))
9014280d 3355 Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
a0d0e21e
LW
3356 RETPUSHUNDEF;
3357 }
146174a9
CB
3358 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3359 if (PL_laststatval < 0) {
3360 (void)PerlIO_close(fp);
5f05dabc 3361 RETPUSHUNDEF;
146174a9 3362 }
bd61b366 3363 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
146174a9
CB
3364 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3365 (void)PerlIO_close(fp);
a0d0e21e 3366 if (len <= 0) {
533c011a 3367 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW
3368 RETPUSHNO; /* special case NFS directories */
3369 RETPUSHYES; /* null file is anything */
3370 }
3371 s = tbuf;
3372 }
3373
3374 /* now scan s to look for textiness */
4633a7c4 3375 /* XXX ASCII dependent code */
a0d0e21e 3376
146174a9
CB
3377#if defined(DOSISH) || defined(USEMYBINMODE)
3378 /* ignore trailing ^Z on short files */
58c0efa5 3379 if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
146174a9
CB
3380 --len;
3381#endif
3382
a0d0e21e
LW
3383 for (i = 0; i < len; i++, s++) {
3384 if (!*s) { /* null never allowed in text */
3385 odd += len;
3386 break;
3387 }
9d116dd7 3388#ifdef EBCDIC
301e8125 3389 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH
3390 odd++;
3391#else
146174a9
CB
3392 else if (*s & 128) {
3393#ifdef USE_LOCALE
2de3dbcc 3394 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS
3395 continue;
3396#endif
3397 /* utf8 characters don't count as odd */
fd400ab9 3398 if (UTF8_IS_START(*s)) {
b3f66c68
GS
3399 int ulen = UTF8SKIP(s);
3400 if (ulen < len - i) {
3401 int j;
3402 for (j = 1; j < ulen; j++) {
fd400ab9 3403 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS
3404 goto not_utf8;
3405 }
3406 --ulen; /* loop does extra increment */
3407 s += ulen;
3408 i += ulen;
3409 continue;
3410 }
3411 }
3412 not_utf8:
3413 odd++;
146174a9 3414 }
a0d0e21e
LW
3415 else if (*s < 32 &&
3416 *s != '\n' && *s != '\r' && *s != '\b' &&
3417 *s != '\t' && *s != '\f' && *s != 27)
3418 odd++;
9d116dd7 3419#endif
a0d0e21e
LW
3420 }
3421
533c011a 3422 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW