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