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