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