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