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