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