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