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