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