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