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