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