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