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