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