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