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