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