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