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