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