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