This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Move substr tests under t/op
[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 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 111# include <sys/utime.h>
112# else
113# include <utime.h>
114# endif
a0d0e21e 115#endif
a0d0e21e 116
cbdc8872 117#ifdef HAS_CHSIZE
cd52b7b2 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 128#endif
129
ff68c719 130#ifdef HAS_FLOCK
131# define FLOCK flock
132#else /* no flock() */
133
36477c24 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 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 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 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 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 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 957 }
958 }
38193a09 959 sv_unmagic(sv, how) ;
55497cff 960 RETPUSHYES;
a0d0e21e
LW		 961}
962
c07a80fd 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))) {
33c27489
GS		 976 SV *osv = SvTIED_obj(sv, mg);
977 if (osv == mg->mg_obj)
978 osv = sv_mortalcopy(osv);
979 PUSHs(osv);
980 RETURN;
c07a80fd 981 }
c07a80fd 982 RETPUSHUNDEF;
983}
984
a0d0e21e
LW		 985PP(pp_dbmopen)
986{
27da23d5 987 dVAR; dSP;
a0d0e21e
LW		 988 dPOPPOPssrl;
989 HV* stash;
07822e36 990 GV *gv = NULL;
a0d0e21e 991
85fbaab2 992 HV * const hv = MUTABLE_HV(POPs);
84bafc02 993 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
da51bb9b 994 stash = gv_stashsv(sv, 0);
8ebc5c01 995 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 996 PUTBACK;
864dbfa3 997 require_pv("AnyDBM_File.pm");
a0d0e21e 998 SPAGAIN;
eff494dd 999 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 1000 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 1001 }
1002
57d3b86d 1003 ENTER;
924508f0 1004 PUSHMARK(SP);
6b05c17a 1005
924508f0 1006 EXTEND(SP, 5);
a0d0e21e
LW		 1007 PUSHs(sv);
1008 PUSHs(left);
1009 if (SvIV(right))
6e449a3a 1010 mPUSHu(O_RDWR|O_CREAT);
a0d0e21e 1011 else
6e449a3a 1012 mPUSHu(O_RDWR);
a0d0e21e 1013 PUSHs(right);
57d3b86d 1014 PUTBACK;
ad64d0ec 1015 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW		 1016 SPAGAIN;
1017
1018 if (!sv_isobject(TOPs)) {
924508f0
GS		 1019 SP--;
1020 PUSHMARK(SP);
a0d0e21e
LW		 1021 PUSHs(sv);
1022 PUSHs(left);
6e449a3a 1023 mPUSHu(O_RDONLY);
a0d0e21e 1024 PUSHs(right);
a0d0e21e 1025 PUTBACK;
ad64d0ec 1026 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW		 1027 SPAGAIN;
1028 }
1029
6b05c17a 1030 if (sv_isobject(TOPs)) {
ad64d0ec
NC		 1031 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1032 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
6b05c17a 1033 }
a0d0e21e
LW		 1034 LEAVE;
1035 RETURN;
1036}
1037
a0d0e21e
LW		 1038PP(pp_sselect)
1039{
a0d0e21e 1040#ifdef HAS_SELECT
97aff369 1041 dVAR; dSP; dTARGET;
a0d0e21e
LW		 1042 register I32 i;
1043 register I32 j;
1044 register char *s;
1045 register SV *sv;
65202027 1046 NV value;
a0d0e21e
LW		 1047 I32 maxlen = 0;
1048 I32 nfound;
1049 struct timeval timebuf;
1050 struct timeval *tbuf = &timebuf;
1051 I32 growsize;
1052 char *fd_sets[4];
1053#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1054 I32 masksize;
1055 I32 offset;
1056 I32 k;
1057
1058# if BYTEORDER & 0xf0000
1059# define ORDERBYTE (0x88888888 - BYTEORDER)
1060# else
1061# define ORDERBYTE (0x4444 - BYTEORDER)
1062# endif
1063
1064#endif
1065
1066 SP -= 4;
1067 for (i = 1; i <= 3; i++) {
c4420975 1068 SV * const sv = SP[i];
15547071
GA		 1069 if (!SvOK(sv))
1070 continue;
1071 if (SvREADONLY(sv)) {
729c079f
NC		 1072 if (SvIsCOW(sv))
1073 sv_force_normal_flags(sv, 0);
15547071 1074 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
6ad8f254 1075 Perl_croak_no_modify(aTHX);
729c079f 1076 }
4ef2275c 1077 if (!SvPOK(sv)) {
a2a5de95 1078 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
4ef2275c
GA		 1079 SvPV_force_nolen(sv); /* force string conversion */
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 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 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
B		 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 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 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 1568 }
1569 else {
3280af22 1570 PUSHs(&PL_sv_undef);
c07a80fd 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 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 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 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 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 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 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
WB		 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 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 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 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 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 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 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 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		 3423 RETPUSHNO;
3424 else
3425 RETPUSHYES;
3426}
3427
a0d0e21e
LW		 3428/* File calls.