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