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