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