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