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