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