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