This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
overloaded <> sometimes left an extra stack arg
[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;
d1bea3d8
DM
361
362 if (PL_op->op_flags & OPf_SPECIAL) {
363 /* call Perl-level glob function instead. Stack args are:
364 * MARK, wildcard, csh_glob context index
365 * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
366 * */
367 return NORMAL;
368 }
369 /* stack args are: wildcard, gv(_GEN_n) */
370
31d632c3 371 tryAMAGICunTARGET(iter_amg, -1);
f5284f61 372
71686f12
GS
373 /* Note that we only ever get here if File::Glob fails to load
374 * without at the same time croaking, for some reason, or if
375 * perl was built with PERL_EXTERNAL_GLOB */
376
d343c3ef 377 ENTER_with_name("glob");
a0d0e21e 378
c90c0ff4 379#ifndef VMS
3280af22 380 if (PL_tainting) {
7bac28a0
PP
381 /*
382 * The external globbing program may use things we can't control,
383 * so for security reasons we must assume the worst.
384 */
385 TAINT;
22c35a8c 386 taint_proper(PL_no_security, "glob");
7bac28a0 387 }
c90c0ff4 388#endif /* !VMS */
7bac28a0 389
3280af22 390 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
159b6efe 391 PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
a0d0e21e 392
3280af22 393 SAVESPTR(PL_rs); /* This is not permanent, either. */
84bafc02 394 PL_rs = newSVpvs_flags("\000", SVs_TEMP);
c07a80fd
PP
395#ifndef DOSISH
396#ifndef CSH
6b88bc9c 397 *SvPVX(PL_rs) = '\n';
a0d0e21e 398#endif /* !CSH */
55497cff 399#endif /* !DOSISH */
c07a80fd 400
a0d0e21e 401 result = do_readline();
d343c3ef 402 LEAVE_with_name("glob");
a0d0e21e
LW
403 return result;
404}
405
a0d0e21e
LW
406PP(pp_rcatline)
407{
97aff369 408 dVAR;
146174a9 409 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW
410 return do_readline();
411}
412
413PP(pp_warn)
414{
97aff369 415 dVAR; dSP; dMARK;
c5df3096
Z
416 SV *exsv;
417 const char *pv;
06bf62c7 418 STRLEN len;
b59aed67 419 if (SP - MARK > 1) {
a0d0e21e 420 dTARGET;
3280af22 421 do_join(TARG, &PL_sv_no, MARK, SP);
c5df3096 422 exsv = TARG;
a0d0e21e
LW
423 SP = MARK + 1;
424 }
b59aed67 425 else if (SP == MARK) {
c5df3096 426 exsv = &PL_sv_no;
b59aed67 427 EXTEND(SP, 1);
83f957ec 428 SP = MARK + 1;
b59aed67 429 }
a0d0e21e 430 else {
c5df3096 431 exsv = TOPs;
a0d0e21e 432 }
06bf62c7 433
c5df3096
Z
434 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
435 /* well-formed exception supplied */
436 }
437 else if (SvROK(ERRSV)) {
438 exsv = ERRSV;
439 }
440 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
441 exsv = sv_mortalcopy(ERRSV);
442 sv_catpvs(exsv, "\t...caught");
443 }
444 else {
445 exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
446 }
447 warn_sv(exsv);
a0d0e21e
LW
448 RETSETYES;
449}
450
451PP(pp_die)
452{
97aff369 453 dVAR; dSP; dMARK;
c5df3096
Z
454 SV *exsv;
455 const char *pv;
06bf62c7 456 STRLEN len;
96e176bf
CL
457#ifdef VMS
458 VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
459#endif
a0d0e21e
LW
460 if (SP - MARK != 1) {
461 dTARGET;
3280af22 462 do_join(TARG, &PL_sv_no, MARK, SP);
c5df3096 463 exsv = TARG;
a0d0e21e
LW
464 SP = MARK + 1;
465 }
466 else {
c5df3096 467 exsv = TOPs;
a0d0e21e 468 }
c5df3096
Z
469
470 if (SvROK(exsv) || (pv = SvPV_const(exsv, len), len)) {
471 /* well-formed exception supplied */
472 }
473 else if (SvROK(ERRSV)) {
474 exsv = ERRSV;
475 if (sv_isobject(exsv)) {
476 HV * const stash = SvSTASH(SvRV(exsv));
477 GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
478 if (gv) {
479 SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
480 SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
481 EXTEND(SP, 3);
482 PUSHMARK(SP);
483 PUSHs(exsv);
484 PUSHs(file);
485 PUSHs(line);
486 PUTBACK;
487 call_sv(MUTABLE_SV(GvCV(gv)),
488 G_SCALAR|G_EVAL|G_KEEPERR);
489 exsv = sv_mortalcopy(*PL_stack_sp--);
05423cc9 490 }
4e6ea2c3 491 }
a0d0e21e 492 }
c5df3096
Z
493 else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
494 exsv = sv_mortalcopy(ERRSV);
495 sv_catpvs(exsv, "\t...propagated");
496 }
497 else {
498 exsv = newSVpvs_flags("Died", SVs_TEMP);
499 }
9fed9930 500 return die_sv(exsv);
a0d0e21e
LW
501}
502
503/* I/O. */
504
505PP(pp_open)
506{
27da23d5 507 dVAR; dSP;
a567e93b
NIS
508 dMARK; dORIGMARK;
509 dTARGET;
a0d0e21e 510 SV *sv;
5b468f54 511 IO *io;
5c144d81 512 const char *tmps;
a0d0e21e 513 STRLEN len;
a567e93b 514 bool ok;
a0d0e21e 515
159b6efe 516 GV * const gv = MUTABLE_GV(*++MARK);
c4420975 517
13be902c 518 if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
cea2e8a9 519 DIE(aTHX_ PL_no_usym, "filehandle");
abc718f2 520
a79db61d
AL
521 if ((io = GvIOp(gv))) {
522 MAGIC *mg;
36477c24 523 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 524
a2a5de95 525 if (IoDIRP(io))
d1d15184
NC
526 Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
527 "Opening dirhandle %s also as a file",
528 GvENAME(gv));
abc718f2 529
ad64d0ec 530 mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
c4420975
AL
531 if (mg) {
532 /* Method's args are same as ours ... */
533 /* ... except handle is replaced by the object */
ad64d0ec 534 *MARK-- = SvTIED_obj(MUTABLE_SV(io), mg);
c4420975
AL
535 PUSHMARK(MARK);
536 PUTBACK;
d343c3ef 537 ENTER_with_name("call_OPEN");
c4420975 538 call_method("OPEN", G_SCALAR);
d343c3ef 539 LEAVE_with_name("call_OPEN");
5616b3e5 540 return NORMAL;
c4420975 541 }
4592e6ca
NIS
542 }
543
a567e93b
NIS
544 if (MARK < SP) {
545 sv = *++MARK;
546 }
547 else {
35a08ec7 548 sv = GvSVn(gv);
a567e93b
NIS
549 }
550
5c144d81 551 tmps = SvPV_const(sv, len);
4608196e 552 ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
a567e93b
NIS
553 SP = ORIGMARK;
554 if (ok)
3280af22
NIS
555 PUSHi( (I32)PL_forkprocess );
556 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW
557 PUSHi(0);
558 else
559 RETPUSHUNDEF;
560 RETURN;
561}
562
f4adce6b 563/* These are private to this function, which is private to this file.
74f0b550
NC
564 Use 0x04 rather than the next available bit, to help the compiler if the
565 architecture can generate more efficient instructions. */
566#define MORTALIZE_NOT_NEEDED 0x04
f4adce6b 567#define TIED_HANDLE_ARGC_SHIFT 3
74f0b550 568
ebc1fde6
NC
569static OP *
570S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
f4adce6b 571 IO *const io, MAGIC *const mg, const U32 flags, ...)
ebc1fde6 572{
f4adce6b
NC
573 U32 argc = flags >> TIED_HANDLE_ARGC_SHIFT;
574
ebc1fde6
NC
575 PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
576
f4adce6b 577 /* Ensure that our flag bits do not overlap. */
74f0b550 578 assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0);
f4adce6b 579 assert((G_WANT >> TIED_HANDLE_ARGC_SHIFT) == 0);
74f0b550 580
ebc1fde6
NC
581 PUSHMARK(sp);
582 PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
bc0c81ca 583 if (argc) {
74f0b550 584 const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED;
bc0c81ca 585 va_list args;
f4adce6b 586 va_start(args, flags);
bc0c81ca
NC
587 do {
588 SV *const arg = va_arg(args, SV *);
74f0b550
NC
589 if(mortalize_not_needed)
590 PUSHs(arg);
591 else
592 mPUSHs(arg);
bc0c81ca
NC
593 } while (--argc);
594 va_end(args);
595 }
596
ebc1fde6
NC
597 PUTBACK;
598 ENTER_with_name("call_tied_handle_method");
74f0b550 599 call_method(methname, flags & G_WANT);
ebc1fde6
NC
600 LEAVE_with_name("call_tied_handle_method");
601 return NORMAL;
602}
603
bc0c81ca 604#define tied_handle_method(a,b,c,d) \
f4adce6b 605 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR)
bc0c81ca 606#define tied_handle_method1(a,b,c,d,e) \
f4adce6b 607 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (1 << TIED_HANDLE_ARGC_SHIFT),e)
bc0c81ca 608#define tied_handle_method2(a,b,c,d,e,f) \
f4adce6b 609 S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR | (2 << TIED_HANDLE_ARGC_SHIFT), e,f)
bc0c81ca 610
a0d0e21e
LW
611PP(pp_close)
612{
27da23d5 613 dVAR; dSP;
159b6efe 614 GV * const gv = (MAXARG == 0) ? PL_defoutgv : MUTABLE_GV(POPs);
1d603a67 615
2addaaf3
NC
616 if (MAXARG == 0)
617 EXTEND(SP, 1);
618
a79db61d
AL
619 if (gv) {
620 IO * const io = GvIO(gv);
621 if (io) {
ad64d0ec 622 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 623 if (mg) {
ebc1fde6 624 return tied_handle_method("CLOSE", SP, io, mg);
a79db61d
AL
625 }
626 }
1d603a67 627 }
54310121 628 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW
629 RETURN;
630}
631
632PP(pp_pipe_op)
633{
a0d0e21e 634#ifdef HAS_PIPE
97aff369 635 dVAR;
9cad6237 636 dSP;
a0d0e21e
LW
637 register IO *rstio;
638 register IO *wstio;
639 int fd[2];
640
159b6efe
NC
641 GV * const wgv = MUTABLE_GV(POPs);
642 GV * const rgv = MUTABLE_GV(POPs);
a0d0e21e
LW
643
644 if (!rgv || !wgv)
645 goto badexit;
646
6e592b3a 647 if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
cea2e8a9 648 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW
649 rstio = GvIOn(rgv);
650 wstio = GvIOn(wgv);
651
652 if (IoIFP(rstio))
653 do_close(rgv, FALSE);
654 if (IoIFP(wstio))
655 do_close(wgv, FALSE);
656
6ad3d225 657 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW
658 goto badexit;
659
460c8493
IZ
660 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
661 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
b5ac89c3 662 IoOFP(rstio) = IoIFP(rstio);
a0d0e21e 663 IoIFP(wstio) = IoOFP(wstio);
50952442
JH
664 IoTYPE(rstio) = IoTYPE_RDONLY;
665 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW
666
667 if (!IoIFP(rstio) || !IoOFP(wstio)) {
a79db61d
AL
668 if (IoIFP(rstio))
669 PerlIO_close(IoIFP(rstio));
670 else
671 PerlLIO_close(fd[0]);
672 if (IoOFP(wstio))
673 PerlIO_close(IoOFP(wstio));
674 else
675 PerlLIO_close(fd[1]);
a0d0e21e
LW
676 goto badexit;
677 }
4771b018
GS
678#if defined(HAS_FCNTL) && defined(F_SETFD)
679 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
680 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
681#endif
a0d0e21e
LW
682 RETPUSHYES;
683
684badexit:
685 RETPUSHUNDEF;
686#else
cea2e8a9 687 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW
688#endif
689}
690
691PP(pp_fileno)
692{
27da23d5 693 dVAR; dSP; dTARGET;
a0d0e21e
LW
694 GV *gv;
695 IO *io;
760ac839 696 PerlIO *fp;
4592e6ca
NIS
697 MAGIC *mg;
698
a0d0e21e
LW
699 if (MAXARG < 1)
700 RETPUSHUNDEF;
159b6efe 701 gv = MUTABLE_GV(POPs);
4592e6ca 702
5b468f54 703 if (gv && (io = GvIO(gv))
ad64d0ec 704 && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
5b468f54 705 {
ebc1fde6 706 return tied_handle_method("FILENO", SP, io, mg);
4592e6ca
NIS
707 }
708
c289d2f7
JH
709 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io))) {
710 /* Can't do this because people seem to do things like
711 defined(fileno($foo)) to check whether $foo is a valid fh.
51087808
NC
712
713 report_evil_fh(gv);
c289d2f7 714 */
a0d0e21e 715 RETPUSHUNDEF;
c289d2f7
JH
716 }
717
760ac839 718 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW
719 RETURN;
720}
721
722PP(pp_umask)
723{
97aff369 724 dVAR;
27da23d5 725 dSP;
d7e492a4 726#ifdef HAS_UMASK
27da23d5 727 dTARGET;
761237fe 728 Mode_t anum;
a0d0e21e 729
a0d0e21e 730 if (MAXARG < 1) {
b0b546b3
GA
731 anum = PerlLIO_umask(022);
732 /* setting it to 022 between the two calls to umask avoids
733 * to have a window where the umask is set to 0 -- meaning
734 * that another thread could create world-writeable files. */
735 if (anum != 022)
736 (void)PerlLIO_umask(anum);
a0d0e21e
LW
737 }
738 else
6ad3d225 739 anum = PerlLIO_umask(POPi);
a0d0e21e
LW
740 TAINT_PROPER("umask");
741 XPUSHi(anum);
742#else
a0288114 743 /* Only DIE if trying to restrict permissions on "user" (self).
eec2d3df
GS
744 * Otherwise it's harmless and more useful to just return undef
745 * since 'group' and 'other' concepts probably don't exist here. */
746 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 747 DIE(aTHX_ "umask not implemented");
6b88bc9c 748 XPUSHs(&PL_sv_undef);
a0d0e21e
LW
749#endif
750 RETURN;
751}
752
753PP(pp_binmode)
754{
27da23d5 755 dVAR; dSP;
a0d0e21e
LW
756 GV *gv;
757 IO *io;
760ac839 758 PerlIO *fp;
a0714e2c 759 SV *discp = NULL;
a0d0e21e
LW
760
761 if (MAXARG < 1)
762 RETPUSHUNDEF;
60382766 763 if (MAXARG > 1) {
16fe6d59 764 discp = POPs;
60382766 765 }
a0d0e21e 766
159b6efe 767 gv = MUTABLE_GV(POPs);
4592e6ca 768
a79db61d 769 if (gv && (io = GvIO(gv))) {
ad64d0ec 770 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 771 if (mg) {
bc0c81ca
NC
772 /* This takes advantage of the implementation of the varargs
773 function, which I don't think that the optimiser will be able to
774 figure out. Although, as it's a static function, in theory it
775 could. */
74f0b550 776 return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
f4adce6b
NC
777 G_SCALAR|MORTALIZE_NOT_NEEDED
778 | (discp
779 ? (1 << TIED_HANDLE_ARGC_SHIFT) : 0),
780 discp);
a79db61d 781 }
4592e6ca 782 }
a0d0e21e 783
50f846a7 784 if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) {
51087808 785 report_evil_fh(gv);
b5fe5ca2 786 SETERRNO(EBADF,RMS_IFI);
50f846a7
SC
787 RETPUSHUNDEF;
788 }
a0d0e21e 789
40d98b49 790 PUTBACK;
f0a78170 791 {
a79b25b7
VP
792 STRLEN len = 0;
793 const char *d = NULL;
794 int mode;
795 if (discp)
796 d = SvPV_const(discp, len);
797 mode = mode_from_discipline(d, len);
f0a78170
NC
798 if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
799 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
800 if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
801 SPAGAIN;
802 RETPUSHUNDEF;
803 }
804 }
805 SPAGAIN;
806 RETPUSHYES;
807 }
808 else {
809 SPAGAIN;
810 RETPUSHUNDEF;
38af81ff 811 }
40d98b49 812 }
a0d0e21e
LW
813}
814
815PP(pp_tie)
816{
27da23d5 817 dVAR; dSP; dMARK;
a0d0e21e 818 HV* stash;
07822e36 819 GV *gv = NULL;
a0d0e21e 820 SV *sv;
1df70142 821 const I32 markoff = MARK - PL_stack_base;
e1ec3a88 822 const char *methname;
14befaf4 823 int how = PERL_MAGIC_tied;
e336de0d 824 U32 items;
c4420975 825 SV *varsv = *++MARK;
a0d0e21e 826
6b05c17a
NIS
827 switch(SvTYPE(varsv)) {
828 case SVt_PVHV:
829 methname = "TIEHASH";
85fbaab2 830 HvEITER_set(MUTABLE_HV(varsv), 0);
6b05c17a
NIS
831 break;
832 case SVt_PVAV:
833 methname = "TIEARRAY";
834 break;
835 case SVt_PVGV:
13be902c 836 case SVt_PVLV:
7850f4d6 837 if (isGV_with_GP(varsv)) {
7c7df812
FC
838 if (SvFAKE(varsv) && !(GvFLAGS(varsv) & GVf_TIEWARNED)) {
839 deprecate("tie on a handle without *");
840 GvFLAGS(varsv) |= GVf_TIEWARNED;
841 }
6e592b3a
BM
842 methname = "TIEHANDLE";
843 how = PERL_MAGIC_tiedscalar;
844 /* For tied filehandles, we apply tiedscalar magic to the IO
845 slot of the GP rather than the GV itself. AMS 20010812 */
846 if (!GvIOp(varsv))
847 GvIOp(varsv) = newIO();
ad64d0ec 848 varsv = MUTABLE_SV(GvIOp(varsv));
6e592b3a
BM
849 break;
850 }
851 /* FALL THROUGH */
6b05c17a
NIS
852 default:
853 methname = "TIESCALAR";
14befaf4 854 how = PERL_MAGIC_tiedscalar;
6b05c17a
NIS
855 break;
856 }
e336de0d 857 items = SP - MARK++;
a91d1d42 858 if (sv_isobject(*MARK)) { /* Calls GET magic. */
d343c3ef 859 ENTER_with_name("call_TIE");
e788e7d3 860 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 861 PUSHMARK(SP);
eb160463 862 EXTEND(SP,(I32)items);
e336de0d
GS
863 while (items--)
864 PUSHs(*MARK++);
865 PUTBACK;
864dbfa3 866 call_method(methname, G_SCALAR);
301e8125 867 }
6b05c17a 868 else {
086d2913
NC
869 /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
870 * will attempt to invoke IO::File::TIEARRAY, with (best case) the
871 * wrong error message, and worse case, supreme action at a distance.
872 * (Sorry obfuscation writers. You're not going to be given this one.)
6b05c17a 873 */
a91d1d42
VP
874 STRLEN len;
875 const char *name = SvPV_nomg_const(*MARK, len);
876 stash = gv_stashpvn(name, len, 0);
6b05c17a 877 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
35c1215d 878 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
a91d1d42 879 methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
6b05c17a 880 }
d343c3ef 881 ENTER_with_name("call_TIE");
e788e7d3 882 PUSHSTACKi(PERLSI_MAGIC);
e336de0d 883 PUSHMARK(SP);
eb160463 884 EXTEND(SP,(I32)items);
e336de0d
GS
885 while (items--)
886 PUSHs(*MARK++);
887 PUTBACK;
ad64d0ec 888 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
6b05c17a 889 }
a0d0e21e
LW
890 SPAGAIN;
891
892 sv = TOPs;
d3acc0f7 893 POPSTACK;
a0d0e21e 894 if (sv_isobject(sv)) {
33c27489 895 sv_unmagic(varsv, how);
ae21d580 896 /* Croak if a self-tie on an aggregate is attempted. */
b881518d 897 if (varsv == SvRV(sv) &&
d87ebaca
YST
898 (SvTYPE(varsv) == SVt_PVAV ||
899 SvTYPE(varsv) == SVt_PVHV))
ae21d580
JH
900 Perl_croak(aTHX_
901 "Self-ties of arrays and hashes are not supported");
a0714e2c 902 sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
a0d0e21e 903 }
d343c3ef 904 LEAVE_with_name("call_TIE");
3280af22 905 SP = PL_stack_base + markoff;
a0d0e21e
LW
906 PUSHs(sv);
907 RETURN;
908}
909
910PP(pp_untie)
911{
27da23d5 912 dVAR; dSP;
5b468f54 913 MAGIC *mg;
33c27489 914 SV *sv = POPs;
1df70142 915 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 916 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
55497cff 917
7c7df812
FC
918 if (isGV_with_GP(sv)) {
919 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
920 deprecate("untie on a handle without *");
921 GvFLAGS(sv) |= GVf_TIEWARNED;
922 }
923 if (!(sv = MUTABLE_SV(GvIOp(sv))))
5b468f54 924 RETPUSHYES;
7c7df812 925 }
5b468f54 926
65eba18f 927 if ((mg = SvTIED_mg(sv, how))) {
1b6737cc 928 SV * const obj = SvRV(SvTIED_obj(sv, mg));
fa2b88e0 929 if (obj) {
c4420975 930 GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
0bd48802 931 CV *cv;
c4420975 932 if (gv && isGV(gv) && (cv = GvCV(gv))) {
fa2b88e0 933 PUSHMARK(SP);
c33ef3ac 934 PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
6e449a3a 935 mXPUSHi(SvREFCNT(obj) - 1);
fa2b88e0 936 PUTBACK;
d343c3ef 937 ENTER_with_name("call_UNTIE");
ad64d0ec 938 call_sv(MUTABLE_SV(cv), G_VOID);
d343c3ef 939 LEAVE_with_name("call_UNTIE");
fa2b88e0
JS
940 SPAGAIN;
941 }
a2a5de95
NC
942 else if (mg && SvREFCNT(obj) > 1) {
943 Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
944 "untie attempted while %"UVuf" inner references still exist",
945 (UV)SvREFCNT(obj) - 1 ) ;
c4420975 946 }
cbdc8872
PP
947 }
948 }
38193a09 949 sv_unmagic(sv, how) ;
55497cff 950 RETPUSHYES;
a0d0e21e
LW
951}
952
c07a80fd
PP
953PP(pp_tied)
954{
97aff369 955 dVAR;
39644a26 956 dSP;
1b6737cc 957 const MAGIC *mg;
33c27489 958 SV *sv = POPs;
1df70142 959 const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
14befaf4 960 ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
5b468f54 961
7c7df812
FC
962 if (isGV_with_GP(sv)) {
963 if (SvFAKE(sv) && !(GvFLAGS(sv) & GVf_TIEWARNED)) {
964 deprecate("tied on a handle without *");
965 GvFLAGS(sv) |= GVf_TIEWARNED;
966 }
967 if (!(sv = MUTABLE_SV(GvIOp(sv))))
5b468f54 968 RETPUSHUNDEF;
7c7df812 969 }
c07a80fd 970
155aba94 971 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS
972 SV *osv = SvTIED_obj(sv, mg);
973 if (osv == mg->mg_obj)
974 osv = sv_mortalcopy(osv);
975 PUSHs(osv);
976 RETURN;
c07a80fd 977 }
c07a80fd
PP
978 RETPUSHUNDEF;
979}
980
a0d0e21e
LW
981PP(pp_dbmopen)
982{
27da23d5 983 dVAR; dSP;
a0d0e21e
LW
984 dPOPPOPssrl;
985 HV* stash;
07822e36 986 GV *gv = NULL;
a0d0e21e 987
85fbaab2 988 HV * const hv = MUTABLE_HV(POPs);
84bafc02 989 SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
da51bb9b 990 stash = gv_stashsv(sv, 0);
8ebc5c01 991 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 992 PUTBACK;
864dbfa3 993 require_pv("AnyDBM_File.pm");
a0d0e21e 994 SPAGAIN;
eff494dd 995 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 996 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW
997 }
998
57d3b86d 999 ENTER;
924508f0 1000 PUSHMARK(SP);
6b05c17a 1001
924508f0 1002 EXTEND(SP, 5);
a0d0e21e
LW
1003 PUSHs(sv);
1004 PUSHs(left);
1005 if (SvIV(right))
6e449a3a 1006 mPUSHu(O_RDWR|O_CREAT);
a0d0e21e 1007 else
6e449a3a 1008 mPUSHu(O_RDWR);
a0d0e21e 1009 PUSHs(right);
57d3b86d 1010 PUTBACK;
ad64d0ec 1011 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW
1012 SPAGAIN;
1013
1014 if (!sv_isobject(TOPs)) {
924508f0
GS
1015 SP--;
1016 PUSHMARK(SP);
a0d0e21e
LW
1017 PUSHs(sv);
1018 PUSHs(left);
6e449a3a 1019 mPUSHu(O_RDONLY);
a0d0e21e 1020 PUSHs(right);
a0d0e21e 1021 PUTBACK;
ad64d0ec 1022 call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
a0d0e21e
LW
1023 SPAGAIN;
1024 }
1025
6b05c17a 1026 if (sv_isobject(TOPs)) {
ad64d0ec
NC
1027 sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1028 sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
6b05c17a 1029 }
a0d0e21e
LW
1030 LEAVE;
1031 RETURN;
1032}
1033
a0d0e21e
LW
1034PP(pp_sselect)
1035{
a0d0e21e 1036#ifdef HAS_SELECT
97aff369 1037 dVAR; dSP; dTARGET;
a0d0e21e
LW
1038 register I32 i;
1039 register I32 j;
1040 register char *s;
1041 register SV *sv;
65202027 1042 NV value;
a0d0e21e
LW
1043 I32 maxlen = 0;
1044 I32 nfound;
1045 struct timeval timebuf;
1046 struct timeval *tbuf = &timebuf;
1047 I32 growsize;
1048 char *fd_sets[4];
1049#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1050 I32 masksize;
1051 I32 offset;
1052 I32 k;
1053
1054# if BYTEORDER & 0xf0000
1055# define ORDERBYTE (0x88888888 - BYTEORDER)
1056# else
1057# define ORDERBYTE (0x4444 - BYTEORDER)
1058# endif
1059
1060#endif
1061
1062 SP -= 4;
1063 for (i = 1; i <= 3; i++) {
c4420975 1064 SV * const sv = SP[i];
15547071
GA
1065 if (!SvOK(sv))
1066 continue;
1067 if (SvREADONLY(sv)) {
729c079f
NC
1068 if (SvIsCOW(sv))
1069 sv_force_normal_flags(sv, 0);
15547071 1070 if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
6ad8f254 1071 Perl_croak_no_modify(aTHX);
729c079f 1072 }
4ef2275c 1073 if (!SvPOK(sv)) {
a2a5de95 1074 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");
4ef2275c
GA
1075 SvPV_force_nolen(sv); /* force string conversion */
1076 }
729c079f 1077 j = SvCUR(sv);
a0d0e21e
LW
1078 if (maxlen < j)
1079 maxlen = j;
1080 }
1081
5ff3f7a4 1082/* little endians can use vecs directly */
e366b469 1083#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
5ff3f7a4 1084# ifdef NFDBITS
a0d0e21e 1085
5ff3f7a4
GS
1086# ifndef NBBY
1087# define NBBY 8
1088# endif
a0d0e21e
LW
1089
1090 masksize = NFDBITS / NBBY;
5ff3f7a4 1091# else
a0d0e21e 1092 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 1093# endif
a0d0e21e
LW
1094 Zero(&fd_sets[0], 4, char*);
1095#endif
1096
ad517f75
MHM
1097# if SELECT_MIN_BITS == 1
1098 growsize = sizeof(fd_set);
1099# else
1100# if defined(__GLIBC__) && defined(__FD_SETSIZE)
1101# undef SELECT_MIN_BITS
1102# define SELECT_MIN_BITS __FD_SETSIZE
1103# endif
e366b469
PG
1104 /* If SELECT_MIN_BITS is greater than one we most probably will want
1105 * to align the sizes with SELECT_MIN_BITS/8 because for example
1106 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1107 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1108 * on (sets/tests/clears bits) is 32 bits. */
1109 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
e366b469
PG
1110# endif
1111
a0d0e21e
LW
1112 sv = SP[4];
1113 if (SvOK(sv)) {
1114 value = SvNV(sv);
1115 if (value < 0.0)
1116 value = 0.0;
1117 timebuf.tv_sec = (long)value;
65202027 1118 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW
1119 timebuf.tv_usec = (long)(value * 1000000.0);
1120 }
1121 else
4608196e 1122 tbuf = NULL;
a0d0e21e
LW
1123
1124 for (i = 1; i <= 3; i++) {
1125 sv = SP[i];
15547071 1126 if (!SvOK(sv) || SvCUR(sv) == 0) {
a0d0e21e
LW
1127 fd_sets[i] = 0;
1128 continue;
1129 }
4ef2275c 1130 assert(SvPOK(sv));
a0d0e21e
LW
1131 j = SvLEN(sv);
1132 if (j < growsize) {
1133 Sv_Grow(sv, growsize);
a0d0e21e 1134 }
c07a80fd
PP
1135 j = SvCUR(sv);
1136 s = SvPVX(sv) + j;
1137 while (++j <= growsize) {
1138 *s++ = '\0';
1139 }
1140
a0d0e21e
LW
1141#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1142 s = SvPVX(sv);
a02a5408 1143 Newx(fd_sets[i], growsize, char);
a0d0e21e
LW
1144 for (offset = 0; offset < growsize; offset += masksize) {
1145 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1146 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1147 }
1148#else
1149 fd_sets[i] = SvPVX(sv);
1150#endif
1151 }
1152
dc4c69d9
JH
1153#ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1154 /* Can't make just the (void*) conditional because that would be
1155 * cpp #if within cpp macro, and not all compilers like that. */
1156 nfound = PerlSock_select(
1157 maxlen * 8,
1158 (Select_fd_set_t) fd_sets[1],
1159 (Select_fd_set_t) fd_sets[2],
1160 (Select_fd_set_t) fd_sets[3],
1161 (void*) tbuf); /* Workaround for compiler bug. */
1162#else
6ad3d225 1163 nfound = PerlSock_select(
a0d0e21e
LW
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 tbuf);
dc4c69d9 1169#endif
a0d0e21e
LW
1170 for (i = 1; i <= 3; i++) {
1171 if (fd_sets[i]) {
1172 sv = SP[i];
1173#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1174 s = SvPVX(sv);
1175 for (offset = 0; offset < growsize; offset += masksize) {
1176 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1177 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1178 }
1179 Safefree(fd_sets[i]);
1180#endif
1181 SvSETMAGIC(sv);
1182 }
1183 }
1184
4189264e 1185 PUSHi(nfound);
a0d0e21e 1186 if (GIMME == G_ARRAY && tbuf) {
65202027
DS
1187 value = (NV)(timebuf.tv_sec) +
1188 (NV)(timebuf.tv_usec) / 1000000.0;
6e449a3a 1189 mPUSHn(value);
a0d0e21e
LW
1190 }
1191 RETURN;
1192#else
cea2e8a9 1193 DIE(aTHX_ "select not implemented");
a0d0e21e
LW
1194#endif
1195}
1196
8226a3d7
NC
1197/*
1198=for apidoc setdefout
1199
1200Sets PL_defoutgv, the default file handle for output, to the passed in
1201typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1202count of the passed in typeglob is increased by one, and the reference count
1203of the typeglob that PL_defoutgv points to is decreased by one.
1204
1205=cut
1206*/
1207
4633a7c4 1208void
864dbfa3 1209Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1210{
97aff369 1211 dVAR;
b37c2d43 1212 SvREFCNT_inc_simple_void(gv);
ef8d46e8 1213 SvREFCNT_dec(PL_defoutgv);
3280af22 1214 PL_defoutgv = gv;
4633a7c4
LW
1215}
1216
a0d0e21e
LW
1217PP(pp_select)
1218{
97aff369 1219 dVAR; dSP; dTARGET;
4633a7c4 1220 HV *hv;
159b6efe 1221 GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
099be4f1 1222 GV * egv = GvEGVx(PL_defoutgv);
4633a7c4 1223
4633a7c4 1224 if (!egv)
3280af22 1225 egv = PL_defoutgv;
099be4f1 1226 hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
4633a7c4 1227 if (! hv)
3280af22 1228 XPUSHs(&PL_sv_undef);
4633a7c4 1229 else {
c4420975 1230 GV * const * const gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1231 if (gvp && *gvp == egv) {
bd61b366 1232 gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
f86702cc
PP
1233 XPUSHTARG;
1234 }
1235 else {
ad64d0ec 1236 mXPUSHs(newRV(MUTABLE_SV(egv)));
f86702cc 1237 }
4633a7c4
LW
1238 }
1239
1240 if (newdefout) {
ded8aa31
GS
1241 if (!GvIO(newdefout))
1242 gv_IOadd(newdefout);
4633a7c4
LW
1243 setdefout(newdefout);
1244 }
1245
a0d0e21e
LW
1246 RETURN;
1247}
1248
1249PP(pp_getc)
1250{
27da23d5 1251 dVAR; dSP; dTARGET;
90133b69 1252 IO *io = NULL;
159b6efe 1253 GV * const gv = (MAXARG==0) ? PL_stdingv : MUTABLE_GV(POPs);
2ae324a7 1254
ac3697cd
NC
1255 if (MAXARG == 0)
1256 EXTEND(SP, 1);
1257
a79db61d 1258 if (gv && (io = GvIO(gv))) {
ad64d0ec 1259 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1260 if (mg) {
0240605e 1261 const U32 gimme = GIMME_V;
f4adce6b 1262 S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme);
0240605e
NC
1263 if (gimme == G_SCALAR) {
1264 SPAGAIN;
a79db61d 1265 SvSetMagicSV_nosteal(TARG, TOPs);
0240605e
NC
1266 }
1267 return NORMAL;
a79db61d 1268 }
2ae324a7 1269 }
90133b69 1270 if (!gv || do_eof(gv)) { /* make sure we have fp with something */
51087808 1271 if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
831e4cc3 1272 report_evil_fh(gv);
b5fe5ca2 1273 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1274 RETPUSHUNDEF;
90133b69 1275 }
bbce6d69 1276 TAINT;
76f68e9b 1277 sv_setpvs(TARG, " ");
9bc64814 1278 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
7d59b7e4
NIS
1279 if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1280 /* Find out how many bytes the char needs */
aa07b2f6 1281 Size_t len = UTF8SKIP(SvPVX_const(TARG));
7d59b7e4
NIS
1282 if (len > 1) {
1283 SvGROW(TARG,len+1);
1284 len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1285 SvCUR_set(TARG,1+len);
1286 }
1287 SvUTF8_on(TARG);
1288 }
a0d0e21e
LW
1289 PUSHTARG;
1290 RETURN;
1291}
1292
76e3520e 1293STATIC OP *
cea2e8a9 1294S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1295{
27da23d5 1296 dVAR;
c09156bb 1297 register PERL_CONTEXT *cx;
f54cb97a 1298 const I32 gimme = GIMME_V;
a0d0e21e 1299
7918f24d
NC
1300 PERL_ARGS_ASSERT_DOFORM;
1301
7b190374
NC
1302 if (cv && CvCLONE(cv))
1303 cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1304
a0d0e21e
LW
1305 ENTER;
1306 SAVETMPS;
1307
146174a9 1308 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
10067d9a 1309 PUSHFORMAT(cx, retop);
fd617465
DM
1310 SAVECOMPPAD();
1311 PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
a0d0e21e 1312
4633a7c4 1313 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW
1314 return CvSTART(cv);
1315}
1316
1317PP(pp_enterwrite)
1318{
97aff369 1319 dVAR;
39644a26 1320 dSP;
a0d0e21e
LW
1321 register GV *gv;
1322 register IO *io;
1323 GV *fgv;
07822e36
JH
1324 CV *cv = NULL;
1325 SV *tmpsv = NULL;
a0d0e21e 1326
2addaaf3 1327 if (MAXARG == 0) {
3280af22 1328 gv = PL_defoutgv;
2addaaf3
NC
1329 EXTEND(SP, 1);
1330 }
a0d0e21e 1331 else {
159b6efe 1332 gv = MUTABLE_GV(POPs);
a0d0e21e 1333 if (!gv)
3280af22 1334 gv = PL_defoutgv;
a0d0e21e 1335 }
a0d0e21e
LW
1336 io = GvIO(gv);
1337 if (!io) {
1338 RETPUSHNO;
1339 }
1340 if (IoFMT_GV(io))
1341 fgv = IoFMT_GV(io);
1342 else
1343 fgv = gv;
1344
a79db61d
AL
1345 if (!fgv)
1346 goto not_a_format_reference;
1347
a0d0e21e 1348 cv = GvFORM(fgv);
a0d0e21e 1349 if (!cv) {
f4a7049d 1350 const char *name;
10edeb5d 1351 tmpsv = sv_newmortal();
f4a7049d
NC
1352 gv_efullname4(tmpsv, fgv, NULL, FALSE);
1353 name = SvPV_nolen_const(tmpsv);
1354 if (name && *name)
1355 DIE(aTHX_ "Undefined format \"%s\" called", name);
a79db61d
AL
1356
1357 not_a_format_reference:
cea2e8a9 1358 DIE(aTHX_ "Not a format reference");
a0d0e21e 1359 }
44a8e56a 1360 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1361 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW
1362}
1363
1364PP(pp_leavewrite)
1365{
27da23d5 1366 dVAR; dSP;
f9c764c5 1367 GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1b6737cc 1368 register IO * const io = GvIOp(gv);
8b8cacda 1369 PerlIO *ofp;
760ac839 1370 PerlIO *fp;
8772537c
AL
1371 SV **newsp;
1372 I32 gimme;
c09156bb 1373 register PERL_CONTEXT *cx;
8f89e5a9 1374 OP *retop;
a0d0e21e 1375
8b8cacda 1376 if (!io || !(ofp = IoOFP(io)))
1377 goto forget_top;
1378
760ac839 1379 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22 1380 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
8b8cacda 1381
3280af22
NIS
1382 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1383 PL_formtarget != PL_toptarget)
a0d0e21e 1384 {
4633a7c4
LW
1385 GV *fgv;
1386 CV *cv;
a0d0e21e
LW
1387 if (!IoTOP_GV(io)) {
1388 GV *topgv;
a0d0e21e
LW
1389
1390 if (!IoTOP_NAME(io)) {
1b6737cc 1391 SV *topname;
a0d0e21e
LW
1392 if (!IoFMT_NAME(io))
1393 IoFMT_NAME(io) = savepv(GvNAME(gv));
0bd0581c 1394 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", GvNAME(gv)));
f776e3cd 1395 topgv = gv_fetchsv(topname, 0, SVt_PVFM);
748a9306 1396 if ((topgv && GvFORM(topgv)) ||
fafc274c 1397 !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
2e0de35c 1398 IoTOP_NAME(io) = savesvpv(topname);
a0d0e21e 1399 else
89529cee 1400 IoTOP_NAME(io) = savepvs("top");
a0d0e21e 1401 }
f776e3cd 1402 topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
a0d0e21e 1403 if (!topgv || !GvFORM(topgv)) {
b929a54b 1404 IoLINES_LEFT(io) = IoPAGE_LEN(io);
a0d0e21e
LW
1405 goto forget_top;
1406 }
1407 IoTOP_GV(io) = topgv;
1408 }
748a9306
LW
1409 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1410 I32 lines = IoLINES_LEFT(io);
504618e9 1411 const char *s = SvPVX_const(PL_formtarget);
8e07c86e
AD
1412 if (lines <= 0) /* Yow, header didn't even fit!!! */
1413 goto forget_top;
748a9306
LW
1414 while (lines-- > 0) {
1415 s = strchr(s, '\n');
1416 if (!s)
1417 break;
1418 s++;
1419 }
1420 if (s) {
f54cb97a 1421 const STRLEN save = SvCUR(PL_formtarget);
aa07b2f6 1422 SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
d75029d0
NIS
1423 do_print(PL_formtarget, ofp);
1424 SvCUR_set(PL_formtarget, save);
3280af22
NIS
1425 sv_chop(PL_formtarget, s);
1426 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW
1427 }
1428 }
a0d0e21e 1429 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
d75029d0 1430 do_print(PL_formfeed, ofp);
a0d0e21e
LW
1431 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1432 IoPAGE(io)++;
3280af22 1433 PL_formtarget = PL_toptarget;
748a9306 1434 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW
1435 fgv = IoTOP_GV(io);
1436 if (!fgv)
cea2e8a9 1437 DIE(aTHX_ "bad top format reference");
4633a7c4 1438 cv = GvFORM(fgv);
1df70142
AL
1439 if (!cv) {
1440 SV * const sv = sv_newmortal();
b464bac0 1441 const char *name;
bd61b366 1442 gv_efullname4(sv, fgv, NULL, FALSE);
e62f0680 1443 name = SvPV_nolen_const(sv);
2dd78f96 1444 if (name && *name)
0e528f24
JH
1445 DIE(aTHX_ "Undefined top format \"%s\" called", name);
1446 else
1447 DIE(aTHX_ "Undefined top format called");
4633a7c4 1448 }
0e528f24 1449 return doform(cv, gv, PL_op);
a0d0e21e
LW
1450 }
1451
1452 forget_top:
3280af22 1453 POPBLOCK(cx,PL_curpm);
a0d0e21e 1454 POPFORMAT(cx);
8f89e5a9 1455 retop = cx->blk_sub.retop;
a0d0e21e
LW
1456 LEAVE;
1457
1458 fp = IoOFP(io);
1459 if (!fp) {
7716c5c5
NC
1460 if (IoIFP(io))
1461 report_wrongway_fh(gv, '<');
c521cf7c 1462 else
7716c5c5 1463 report_evil_fh(gv);
3280af22 1464 PUSHs(&PL_sv_no);
a0d0e21e
LW
1465 }
1466 else {
3280af22 1467 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
a2a5de95 1468 Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
a0d0e21e 1469 }
d75029d0 1470 if (!do_print(PL_formtarget, fp))
3280af22 1471 PUSHs(&PL_sv_no);
a0d0e21e 1472 else {
3280af22
NIS
1473 FmLINES(PL_formtarget) = 0;
1474 SvCUR_set(PL_formtarget, 0);
1475 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1476 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1477 (void)PerlIO_flush(fp);
3280af22 1478 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1479 }
1480 }
9cbac4c7 1481 /* bad_ofp: */
3280af22 1482 PL_formtarget = PL_bodytarget;
a0d0e21e 1483 PUTBACK;
29033a8a
SH
1484 PERL_UNUSED_VAR(newsp);
1485 PERL_UNUSED_VAR(gimme);
8f89e5a9 1486 return retop;
a0d0e21e
LW
1487}
1488
1489PP(pp_prtf)
1490{
27da23d5 1491 dVAR; dSP; dMARK; dORIGMARK;
a0d0e21e 1492 IO *io;
760ac839 1493 PerlIO *fp;
26db47c4 1494 SV *sv;
a0d0e21e 1495
159b6efe
NC
1496 GV * const gv
1497 = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
46fc3d4c 1498
a79db61d 1499 if (gv && (io = GvIO(gv))) {
ad64d0ec 1500 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d
AL
1501 if (mg) {
1502 if (MARK == ORIGMARK) {
1503 MEXTEND(SP, 1);
1504 ++MARK;
1505 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1506 ++SP;
1507 }
1508 PUSHMARK(MARK - 1);
ad64d0ec 1509 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
a79db61d
AL
1510 PUTBACK;
1511 ENTER;
1512 call_method("PRINTF", G_SCALAR);
1513 LEAVE;
5616b3e5 1514 return NORMAL;
a79db61d 1515 }
46fc3d4c
PP
1516 }
1517
561b68a9 1518 sv = newSV(0);
a0d0e21e 1519 if (!(io = GvIO(gv))) {
51087808 1520 report_evil_fh(gv);
93189314 1521 SETERRNO(EBADF,RMS_IFI);
a0d0e21e
LW
1522 goto just_say_no;
1523 }
1524 else if (!(fp = IoOFP(io))) {
7716c5c5
NC
1525 if (IoIFP(io))
1526 report_wrongway_fh(gv, '<');
1527 else if (ckWARN(WARN_CLOSED))
1528 report_evil_fh(gv);
93189314 1529 SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
a0d0e21e
LW
1530 goto just_say_no;
1531 }
1532 else {
20ee07fb
RGS
1533 if (SvTAINTED(MARK[1]))
1534 TAINT_PROPER("printf");
a0d0e21e
LW
1535 do_sprintf(sv, SP - MARK, MARK + 1);
1536 if (!do_print(sv, fp))
1537 goto just_say_no;
1538
1539 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1540 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW
1541 goto just_say_no;
1542 }
1543 SvREFCNT_dec(sv);
1544 SP = ORIGMARK;
3280af22 1545 PUSHs(&PL_sv_yes);
a0d0e21e
LW
1546 RETURN;
1547
1548 just_say_no:
1549 SvREFCNT_dec(sv);
1550 SP = ORIGMARK;
3280af22 1551 PUSHs(&PL_sv_undef);
a0d0e21e
LW
1552 RETURN;
1553}
1554
c07a80fd
PP
1555PP(pp_sysopen)
1556{
97aff369 1557 dVAR;
39644a26 1558 dSP;
1df70142
AL
1559 const int perm = (MAXARG > 3) ? POPi : 0666;
1560 const int mode = POPi;
1b6737cc 1561 SV * const sv = POPs;
159b6efe 1562 GV * const gv = MUTABLE_GV(POPs);
1b6737cc 1563 STRLEN len;
c07a80fd 1564
4592e6ca 1565 /* Need TIEHANDLE method ? */
1b6737cc 1566 const char * const tmps = SvPV_const(sv, len);
e62f0680 1567 /* FIXME? do_open should do const */
4608196e 1568 if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
c07a80fd 1569 IoLINES(GvIOp(gv)) = 0;
3280af22 1570 PUSHs(&PL_sv_yes);
c07a80fd
PP
1571 }
1572 else {
3280af22 1573 PUSHs(&PL_sv_undef);
c07a80fd
PP
1574 }
1575 RETURN;
1576}
1577
a0d0e21e
LW
1578PP(pp_sysread)
1579{
27da23d5 1580 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 1581 int offset;
a0d0e21e
LW
1582 IO *io;
1583 char *buffer;
5b54f415 1584 SSize_t length;
eb5c063a 1585 SSize_t count;
1e422769 1586 Sock_size_t bufsize;
748a9306 1587 SV *bufsv;
a0d0e21e 1588 STRLEN blen;
eb5c063a 1589 int fp_utf8;
1dd30107
NC
1590 int buffer_utf8;
1591 SV *read_target;
eb5c063a
NIS
1592 Size_t got = 0;
1593 Size_t wanted;
1d636c13 1594 bool charstart = FALSE;
87330c3c
JH
1595 STRLEN charskip = 0;
1596 STRLEN skip = 0;
a0d0e21e 1597
159b6efe 1598 GV * const gv = MUTABLE_GV(*++MARK);
5b468f54 1599 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1b6737cc 1600 && gv && (io = GvIO(gv)) )
137443ea 1601 {
ad64d0ec 1602 const MAGIC * mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1b6737cc 1603 if (mg) {
1b6737cc 1604 PUSHMARK(MARK-1);
ad64d0ec 1605 *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
1b6737cc
AL
1606 ENTER;
1607 call_method("READ", G_SCALAR);
1608 LEAVE;
5616b3e5 1609 return NORMAL;
1b6737cc 1610 }
2ae324a7
PP
1611 }
1612
a0d0e21e
LW
1613 if (!gv)
1614 goto say_undef;
748a9306 1615 bufsv = *++MARK;
ff68c719 1616 if (! SvOK(bufsv))
76f68e9b 1617 sv_setpvs(bufsv, "");
a0d0e21e 1618 length = SvIVx(*++MARK);
748a9306 1619 SETERRNO(0,0);
a0d0e21e
LW
1620 if (MARK < SP)
1621 offset = SvIVx(*++MARK);
1622 else
1623 offset = 0;
1624 io = GvIO(gv);
b5fe5ca2 1625 if (!io || !IoIFP(io)) {
51087808 1626 report_evil_fh(gv);
b5fe5ca2 1627 SETERRNO(EBADF,RMS_IFI);
a0d0e21e 1628 goto say_undef;
b5fe5ca2 1629 }
0064a8a9 1630 if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
7d59b7e4 1631 buffer = SvPVutf8_force(bufsv, blen);
1e54db1a 1632 /* UTF-8 may not have been set if they are all low bytes */
eb5c063a 1633 SvUTF8_on(bufsv);
9b9d7ce8 1634 buffer_utf8 = 0;
7d59b7e4
NIS
1635 }
1636 else {
1637 buffer = SvPV_force(bufsv, blen);
1dd30107 1638 buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
7d59b7e4
NIS
1639 }
1640 if (length < 0)
1641 DIE(aTHX_ "Negative length");
eb5c063a 1642 wanted = length;
7d59b7e4 1643
d0965105
JH
1644 charstart = TRUE;
1645 charskip = 0;
87330c3c 1646 skip = 0;
d0965105 1647
a0d0e21e 1648#ifdef HAS_SOCKET
533c011a 1649 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1650 char namebuf[MAXPATHLEN];
17a8c7ba 1651#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE) || defined(__QNXNTO__)
490ab354
JH
1652 bufsize = sizeof (struct sockaddr_in);
1653#else
46fc3d4c 1654 bufsize = sizeof namebuf;
490ab354 1655#endif
abf95952
IZ
1656#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1657 if (bufsize >= 256)
1658 bufsize = 255;
1659#endif
eb160463 1660 buffer = SvGROW(bufsv, (STRLEN)(length+1));
bbce6d69 1661 /* 'offset' means 'flags' here */
eb5c063a 1662 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
10edeb5d 1663 (struct sockaddr *)namebuf, &bufsize);
eb5c063a 1664 if (count < 0)
a0d0e21e 1665 RETPUSHUNDEF;
8eb023a9
DM
1666 /* MSG_TRUNC can give oversized count; quietly lose it */
1667 if (count > length)
1668 count = length;
4107cc59
OF
1669#ifdef EPOC
1670 /* Bogus return without padding */
1671 bufsize = sizeof (struct sockaddr_in);
1672#endif
eb5c063a 1673 SvCUR_set(bufsv, count);
748a9306
LW
1674 *SvEND(bufsv) = '\0';
1675 (void)SvPOK_only(bufsv);
eb5c063a
NIS
1676 if (fp_utf8)
1677 SvUTF8_on(bufsv);
748a9306 1678 SvSETMAGIC(bufsv);
aac0dd9a 1679 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1680 if (!(IoFLAGS(io) & IOf_UNTAINT))
1681 SvTAINTED_on(bufsv);
a0d0e21e 1682 SP = ORIGMARK;
46fc3d4c 1683 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW
1684 PUSHs(TARG);
1685 RETURN;
1686 }
1687#else
911d147d 1688 if (PL_op->op_type == OP_RECV)
cea2e8a9 1689 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1690#endif
eb5c063a
NIS
1691 if (DO_UTF8(bufsv)) {
1692 /* offset adjust in characters not bytes */
1693 blen = sv_len_utf8(bufsv);
7d59b7e4 1694 }
bbce6d69 1695 if (offset < 0) {
eb160463 1696 if (-offset > (int)blen)
cea2e8a9 1697 DIE(aTHX_ "Offset outside string");
bbce6d69
PP
1698 offset += blen;
1699 }
eb5c063a
NIS
1700 if (DO_UTF8(bufsv)) {
1701 /* convert offset-as-chars to offset-as-bytes */
6960c29a
CH
1702 if (offset >= (int)blen)
1703 offset += SvCUR(bufsv) - blen;
1704 else
1705 offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
eb5c063a
NIS
1706 }
1707 more_bytes:
cd52b7b2 1708 bufsize = SvCUR(bufsv);
1dd30107
NC
1709 /* Allocating length + offset + 1 isn't perfect in the case of reading
1710 bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1711 unduly.
1712 (should be 2 * length + offset + 1, or possibly something longer if
1713 PL_encoding is true) */
eb160463 1714 buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
27da23d5 1715 if (offset > 0 && (Sock_size_t)offset > bufsize) { /* Zero any newly allocated space */
cd52b7b2
PP
1716 Zero(buffer+bufsize, offset-bufsize, char);
1717 }
eb5c063a 1718 buffer = buffer + offset;
1dd30107
NC
1719 if (!buffer_utf8) {
1720 read_target = bufsv;
1721 } else {
1722 /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1723 concatenate it to the current buffer. */
1724
1725 /* Truncate the existing buffer to the start of where we will be
1726 reading to: */
1727 SvCUR_set(bufsv, offset);
1728
1729 read_target = sv_newmortal();
862a34c6 1730 SvUPGRADE(read_target, SVt_PV);
fe2774ed 1731 buffer = SvGROW(read_target, (STRLEN)(length + 1));
1dd30107 1732 }
eb5c063a 1733
533c011a 1734 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1735#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1736 if (IoTYPE(io) == IoTYPE_SOCKET) {
eb5c063a
NIS
1737 count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1738 buffer, length, 0);
a7092146
GS
1739 }
1740 else
1741#endif
1742 {
eb5c063a
NIS
1743 count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1744 buffer, length);
a7092146 1745 }
a0d0e21e
LW
1746 }
1747 else
1748#ifdef HAS_SOCKET__bad_code_maybe
50952442 1749 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1750 char namebuf[MAXPATHLEN];
490ab354
JH
1751#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1752 bufsize = sizeof (struct sockaddr_in);
1753#else
46fc3d4c 1754 bufsize = sizeof namebuf;
490ab354 1755#endif
eb5c063a 1756 count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
46fc3d4c 1757 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW
1758 }
1759 else
1760#endif
3b02c43c 1761 {
eb5c063a
NIS
1762 count = PerlIO_read(IoIFP(io), buffer, length);
1763 /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1764 if (count == 0 && PerlIO_error(IoIFP(io)))
1765 count = -1;
3b02c43c 1766 }
eb5c063a 1767 if (count < 0) {
7716c5c5 1768 if (IoTYPE(io) == IoTYPE_WRONLY)
a5390457 1769 report_wrongway_fh(gv, '>');
a0d0e21e 1770 goto say_undef;
af8c498a 1771 }
aa07b2f6 1772 SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1dd30107
NC
1773 *SvEND(read_target) = '\0';
1774 (void)SvPOK_only(read_target);
0064a8a9 1775 if (fp_utf8 && !IN_BYTES) {
eb5c063a 1776 /* Look at utf8 we got back and count the characters */
1df70142 1777 const char *bend = buffer + count;
eb5c063a 1778 while (buffer < bend) {
d0965105
JH
1779 if (charstart) {
1780 skip = UTF8SKIP(buffer);
1781 charskip = 0;
1782 }
1783 if (buffer - charskip + skip > bend) {
eb5c063a
NIS
1784 /* partial character - try for rest of it */
1785 length = skip - (bend-buffer);
aa07b2f6 1786 offset = bend - SvPVX_const(bufsv);
d0965105
JH
1787 charstart = FALSE;
1788 charskip += count;
eb5c063a
NIS
1789 goto more_bytes;
1790 }
1791 else {
1792 got++;
1793 buffer += skip;
d0965105
JH
1794 charstart = TRUE;
1795 charskip = 0;
eb5c063a
NIS
1796 }
1797 }
1798 /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1799 provided amount read (count) was what was requested (length)
1800 */
1801 if (got < wanted && count == length) {
d0965105 1802 length = wanted - got;
aa07b2f6 1803 offset = bend - SvPVX_const(bufsv);
eb5c063a
NIS
1804 goto more_bytes;
1805 }
1806 /* return value is character count */
1807 count = got;
1808 SvUTF8_on(bufsv);
1809 }
1dd30107
NC
1810 else if (buffer_utf8) {
1811 /* Let svcatsv upgrade the bytes we read in to utf8.
1812 The buffer is a mortal so will be freed soon. */
1813 sv_catsv_nomg(bufsv, read_target);
1814 }
748a9306 1815 SvSETMAGIC(bufsv);
aac0dd9a 1816 /* This should not be marked tainted if the fp is marked clean */
bbce6d69
PP
1817 if (!(IoFLAGS(io) & IOf_UNTAINT))
1818 SvTAINTED_on(bufsv);
a0d0e21e 1819 SP = ORIGMARK;
eb5c063a 1820 PUSHi(count);
a0d0e21e
LW
1821 RETURN;
1822
1823 say_undef:
1824 SP = ORIGMARK;
1825 RETPUSHUNDEF;
1826}
1827
a0d0e21e
LW
1828PP(pp_send)
1829{
27da23d5 1830 dVAR; dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 1831 IO *io;
748a9306 1832 SV *bufsv;
83003860 1833 const char *buffer;
8c99d73e 1834 SSize_t retval;
a0d0e21e 1835 STRLEN blen;
c9cb0f41 1836 STRLEN orig_blen_bytes;
64a1bc8e 1837 const int op_type = PL_op->op_type;
c9cb0f41
NC
1838 bool doing_utf8;
1839 U8 *tmpbuf = NULL;
64a1bc8e 1840
159b6efe 1841 GV *const gv = MUTABLE_GV(*++MARK);
14befaf4 1842 if (PL_op->op_type == OP_SYSWRITE
a79db61d 1843 && gv && (io = GvIO(gv))) {
ad64d0ec 1844 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 1845 if (mg) {
a79db61d 1846 if (MARK == SP - 1) {
c8834ab7
TC
1847 SV *sv = *SP;
1848 mXPUSHi(sv_len(sv));
a79db61d
AL
1849 PUTBACK;
1850 }
1851
1852 PUSHMARK(ORIGMARK);
ad64d0ec 1853 *(ORIGMARK+1) = SvTIED_obj(MUTABLE_SV(io), mg);
a79db61d
AL
1854 ENTER;
1855 call_method("WRITE", G_SCALAR);
1856 LEAVE;
5616b3e5 1857 return NORMAL;
64a1bc8e 1858 }
1d603a67 1859 }
a0d0e21e
LW
1860 if (!gv)
1861 goto say_undef;
64a1bc8e 1862
748a9306 1863 bufsv = *++MARK;
64a1bc8e 1864
748a9306 1865 SETERRNO(0,0);
a0d0e21e 1866 io = GvIO(gv);
cf167416 1867 if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
8c99d73e 1868 retval = -1;
51087808
NC
1869 if (io && IoIFP(io))
1870 report_wrongway_fh(gv, '<');
1871 else
1872 report_evil_fh(gv);
b5fe5ca2 1873 SETERRNO(EBADF,RMS_IFI);
7d59b7e4
NIS
1874 goto say_undef;
1875 }
1876
c9cb0f41
NC
1877 /* Do this first to trigger any overloading. */
1878 buffer = SvPV_const(bufsv, blen);
1879 orig_blen_bytes = blen;
1880 doing_utf8 = DO_UTF8(bufsv);
1881
7d59b7e4 1882 if (PerlIO_isutf8(IoIFP(io))) {
6aa2f6a7 1883 if (!SvUTF8(bufsv)) {
c9cb0f41
NC
1884 /* We don't modify the original scalar. */
1885 tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1886 buffer = (char *) tmpbuf;
1887 doing_utf8 = TRUE;
1888 }
a0d0e21e 1889 }
c9cb0f41
NC
1890 else if (doing_utf8) {
1891 STRLEN tmplen = blen;
a79db61d 1892 U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
c9cb0f41
NC
1893 if (!doing_utf8) {
1894 tmpbuf = result;
1895 buffer = (char *) tmpbuf;
1896 blen = tmplen;
1897 }
1898 else {
1899 assert((char *)result == buffer);
1900 Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
1901 }
7d59b7e4
NIS
1902 }
1903
64a1bc8e 1904 if (op_type == OP_SYSWRITE) {
c9cb0f41
NC
1905 Size_t length = 0; /* This length is in characters. */
1906 STRLEN blen_chars;
7d59b7e4 1907 IV offset;
c9cb0f41
NC
1908
1909 if (doing_utf8) {
1910 if (tmpbuf) {
1911 /* The SV is bytes, and we've had to upgrade it. */
1912 blen_chars = orig_blen_bytes;
1913 } else {
1914 /* The SV really is UTF-8. */
1915 if (SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1916 /* Don't call sv_len_utf8 again because it will call magic
1917 or overloading a second time, and we might get back a
1918 different result. */
9a206dfd 1919 blen_chars = utf8_length((U8*)buffer, (U8*)buffer + blen);
c9cb0f41
NC
1920 } else {
1921 /* It's safe, and it may well be cached. */
1922 blen_chars = sv_len_utf8(bufsv);
1923 }
1924 }
1925 } else {
1926 blen_chars = blen;
1927 }
1928
1929 if (MARK >= SP) {
1930 length = blen_chars;
1931 } else {
1932#if Size_t_size > IVSIZE
1933 length = (Size_t)SvNVx(*++MARK);
1934#else
1935 length = (Size_t)SvIVx(*++MARK);
1936#endif
4b0c4b6f
NC
1937 if ((SSize_t)length < 0) {
1938 Safefree(tmpbuf);
c9cb0f41 1939 DIE(aTHX_ "Negative length");
4b0c4b6f 1940 }
7d59b7e4 1941 }
c9cb0f41 1942
bbce6d69 1943 if (MARK < SP) {
a0d0e21e 1944 offset = SvIVx(*++MARK);
bbce6d69 1945 if (offset < 0) {
4b0c4b6f
NC
1946 if (-offset > (IV)blen_chars) {
1947 Safefree(tmpbuf);
cea2e8a9 1948 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1949 }
c9cb0f41 1950 offset += blen_chars;
3c946528 1951 } else if (offset > (IV)blen_chars) {
4b0c4b6f 1952 Safefree(tmpbuf);
cea2e8a9 1953 DIE(aTHX_ "Offset outside string");
4b0c4b6f 1954 }
bbce6d69 1955 } else
a0d0e21e 1956 offset = 0;
c9cb0f41
NC
1957 if (length > blen_chars - offset)
1958 length = blen_chars - offset;
1959 if (doing_utf8) {
1960 /* Here we convert length from characters to bytes. */
1961 if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
1962 /* Either we had to convert the SV, or the SV is magical, or
1963 the SV has overloading, in which case we can't or mustn't
1964 or mustn't call it again. */
1965
1966 buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1967 length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1968 } else {
1969 /* It's a real UTF-8 SV, and it's not going to change under
1970 us. Take advantage of any cache. */
1971 I32 start = offset;
1972 I32 len_I32 = length;
1973
1974 /* Convert the start and end character positions to bytes.
1975 Remember that the second argument to sv_pos_u2b is relative
1976 to the first. */
1977 sv_pos_u2b(bufsv, &start, &len_I32);
1978
1979 buffer += start;
1980 length = len_I32;
1981 }
7d59b7e4
NIS
1982 }
1983 else {
1984 buffer = buffer+offset;
1985 }
a7092146 1986#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1987 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1988 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1989 buffer, length, 0);
a7092146
GS
1990 }
1991 else
1992#endif
1993 {
94e4c244 1994 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1995 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
7d59b7e4 1996 buffer, length);
a7092146 1997 }
a0d0e21e
LW
1998 }
1999#ifdef HAS_SOCKET
64a1bc8e
NC
2000 else {
2001 const int flags = SvIVx(*++MARK);
2002 if (SP > MARK) {
2003 STRLEN mlen;
2004 char * const sockbuf = SvPVx(*++MARK, mlen);
2005 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
2006 flags, (struct sockaddr *)sockbuf, mlen);
2007 }
2008 else {
2009 retval
2010 = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
2011 }
a0d0e21e 2012 }
a0d0e21e
LW
2013#else
2014 else
cea2e8a9 2015 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 2016#endif
c9cb0f41 2017
8c99d73e 2018 if (retval < 0)
a0d0e21e
LW
2019 goto say_undef;
2020 SP = ORIGMARK;
c9cb0f41 2021 if (doing_utf8)
f36eea10 2022 retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
4b0c4b6f 2023
a79db61d 2024 Safefree(tmpbuf);
8c99d73e
GS
2025#if Size_t_size > IVSIZE
2026 PUSHn(retval);
2027#else
2028 PUSHi(retval);
2029#endif
a0d0e21e
LW
2030 RETURN;
2031
2032 say_undef:
a79db61d 2033 Safefree(tmpbuf);
a0d0e21e
LW
2034 SP = ORIGMARK;
2035 RETPUSHUNDEF;
2036}
2037
a0d0e21e
LW
2038PP(pp_eof)
2039{
27da23d5 2040 dVAR; dSP;
a0d0e21e 2041 GV *gv;
32e65323
CS
2042 IO *io;
2043 MAGIC *mg;
bc0c81ca
NC
2044 /*
2045 * in Perl 5.12 and later, the additional parameter is a bitmask:
2046 * 0 = eof
2047 * 1 = eof(FH)
2048 * 2 = eof() <- ARGV magic
2049 *
2050 * I'll rely on the compiler's trace flow analysis to decide whether to
2051 * actually assign this out here, or punt it into the only block where it is
2052 * used. Doing it out here is DRY on the condition logic.
2053 */
2054 unsigned int which;
a0d0e21e 2055
bc0c81ca 2056 if (MAXARG) {
32e65323 2057 gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
bc0c81ca
NC
2058 which = 1;
2059 }
b5f55170
NC
2060 else {
2061 EXTEND(SP, 1);
2062
bc0c81ca 2063 if (PL_op->op_flags & OPf_SPECIAL) {
b5f55170 2064 gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
bc0c81ca
NC
2065 which = 2;
2066 }
2067 else {
b5f55170 2068 gv = PL_last_in_gv; /* eof */
bc0c81ca
NC
2069 which = 0;
2070 }
b5f55170 2071 }
32e65323
CS
2072
2073 if (!gv)
2074 RETPUSHNO;
2075
2076 if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
74f0b550 2077 return tied_handle_method1("EOF", SP, io, mg, newSVuv(which));
146174a9 2078 }
4592e6ca 2079
32e65323
CS
2080 if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
2081 if (io && !IoIFP(io)) {
2082 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
2083 IoLINES(io) = 0;
2084 IoFLAGS(io) &= ~IOf_START;
2085 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2086 if (GvSV(gv))
2087 sv_setpvs(GvSV(gv), "-");
2088 else
2089 GvSV(gv) = newSVpvs("-");
2090 SvSETMAGIC(GvSV(gv));
2091 }
2092 else if (!nextargv(gv))
2093 RETPUSHYES;
6136c704 2094 }
4592e6ca
NIS
2095 }
2096
32e65323 2097 PUSHs(boolSV(do_eof(gv)));
a0d0e21e
LW
2098 RETURN;
2099}
2100
2101PP(pp_tell)
2102{
27da23d5 2103 dVAR; dSP; dTARGET;
301e8125 2104 GV *gv;
5b468f54 2105 IO *io;
a0d0e21e 2106
c4420975 2107 if (MAXARG != 0)
159b6efe 2108 PL_last_in_gv = MUTABLE_GV(POPs);
ac3697cd
NC
2109 else
2110 EXTEND(SP, 1);
c4420975 2111 gv = PL_last_in_gv;
4592e6ca 2112
a79db61d 2113 if (gv && (io = GvIO(gv))) {
ad64d0ec 2114 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2115 if (mg) {
ebc1fde6 2116 return tied_handle_method("TELL", SP, io, mg);
a79db61d 2117 }
4592e6ca 2118 }
f4817f32 2119 else if (!gv) {
f03173f2
RGS
2120 if (!errno)
2121 SETERRNO(EBADF,RMS_IFI);
2122 PUSHi(-1);
2123 RETURN;
2124 }
4592e6ca 2125
146174a9
CB
2126#if LSEEKSIZE > IVSIZE
2127 PUSHn( do_tell(gv) );
2128#else
a0d0e21e 2129 PUSHi( do_tell(gv) );
146174a9 2130#endif
a0d0e21e
LW
2131 RETURN;
2132}
2133
137443ea
PP
2134PP(pp_sysseek)
2135{
27da23d5 2136 dVAR; dSP;
1df70142 2137 const int whence = POPi;
146174a9 2138#if LSEEKSIZE > IVSIZE
7452cf6a 2139 const Off_t offset = (Off_t)SvNVx(POPs);
146174a9 2140#else
7452cf6a 2141 const Off_t offset = (Off_t)SvIVx(POPs);
146174a9 2142#endif
a0d0e21e 2143
159b6efe 2144 GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
a79db61d 2145 IO *io;
4592e6ca 2146
a79db61d 2147 if (gv && (io = GvIO(gv))) {
ad64d0ec 2148 MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
a79db61d 2149 if (mg) {
cb50131a 2150#if LSEEKSIZE > IVSIZE
74f0b550 2151 SV *const offset_sv = newSVnv((NV) offset);
cb50131a 2152#else
74f0b550 2153 SV *const offset_sv = newSViv(offset);
cb50131a 2154#endif
bc0c81ca
NC
2155
2156 return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
74f0b550 2157 newSViv(whence));
a79db61d 2158 }
4592e6ca
NIS
2159 }
2160
533c011a 2161 if (PL_op->op_type == OP_SEEK)
8903cb82
PP
2162 PUSHs(boolSV(do_seek(gv, offset, whence)));
2163 else {
0bcc34c2 2164 const Off_t sought = do_sysseek(gv, offset, whence);
b448e4fe 2165 if (sought < 0)
146174a9
CB
2166 PUSHs(&PL_sv_undef);
2167 else {
7452cf6a 2168 SV* const sv = sought ?
146174a9 2169#if LSEEKSIZE > IVSIZE
b448e4fe 2170 newSVnv((NV)sought)
146174a9 2171#else
b448e4fe 2172 newSViv(sought)
146174a9
CB
2173#endif
2174 : newSVpvn(zero_but_true, ZBTLEN);
6e449a3a 2175 mPUSHs(sv);
146174a9 2176 }
8903cb82 2177 }
a0d0e21e
LW
2178 RETURN;
2179}
2180
2181PP(pp_truncate)
2182{
97aff369 2183 dVAR;
39644a26 2184 dSP;
8c99d73e
GS
2185 /* There seems to be no consensus on the length type of truncate()
2186 * and ftruncate(), both off_t and size_t have supporters. In
2187 * general one would think that when using large files, off_t is
2188 * at least as wide as size_t, so using an off_t should be okay. */
2189 /* XXX Configure probe for the length type of *truncate() needed XXX */
0bcc34c2 2190 Off_t len;
a0d0e21e 2191
25342a55 2192#if Off_t_size > IVSIZE
0bcc34c2 2193 len = (Off_t)POPn;
8c99d73e 2194#else
0bcc34c2 2195 len = (Off_t)POPi;
8c99d73e
GS
2196#endif
2197 /* Checking for length < 0 is problematic as the type might or
301e8125 2198 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2199 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2200 SETERRNO(0,0);
d05c1ba0 2201 {
d05c1ba0
JH
2202 int result = 1;
2203 GV *tmpgv;
090bf15b
SR
2204 IO *io;
2205
d05c1ba0 2206 if (PL_op->op_flags & OPf_SPECIAL) {
f776e3cd 2207 tmpgv = gv_fetchsv(POPs, 0, SVt_PVIO);
d05c1ba0 2208
090bf15b
SR
2209 do_ftruncate_gv:
2210 if (!GvIO(tmpgv))
2211 result = 0;
d05c1ba0 2212 else {
090bf15b
SR
2213 PerlIO *fp;
2214 io = GvIOp(tmpgv);
2215 do_ftruncate_io:
2216 TAINT_PROPER("truncate");
2217 if (!(fp = IoIFP(io))) {
2218 result = 0;
2219 }
2220 else {
2221 PerlIO_flush(fp);
cbdc8872 2222#ifdef HAS_TRUNCATE
090bf15b 2223 if (ftruncate(PerlIO_fileno(fp), len) < 0)
301e8125 2224#else
090bf15b 2225 if (my_chsize(PerlIO_fileno(fp), len) < 0)
cbdc8872 2226#endif
090bf15b
SR
2227 result = 0;
2228 }
d05c1ba0 2229 }
cbdc8872 2230 }
d05c1ba0 2231 else {
7452cf6a 2232 SV * const sv = POPs;
83003860 2233 const char *name;
7a5fd60d 2234
6e592b3a 2235 if (isGV_with_GP(sv)) {
159b6efe 2236 tmpgv = MUTABLE_GV(sv); /* *main::FRED for example */
090bf15b 2237 goto do_ftruncate_gv;
d05c1ba0 2238 }
6e592b3a 2239 else if (SvROK(sv) && isGV_with_GP(SvRV(sv))) {
159b6efe 2240 tmpgv = MUTABLE_GV(SvRV(sv)); /* \*main::FRED for example */
090bf15b
SR
2241 goto do_ftruncate_gv;
2242 }
2243 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
a45c7426 2244 io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
090bf15b 2245 goto do_ftruncate_io;
d05c1ba0 2246 }
1e422769 2247
83003860 2248 name = SvPV_nolen_const(sv);
d05c1ba0 2249 TAINT_PROPER("truncate");
cbdc8872 2250#ifdef HAS_TRUNCATE
d05c1ba0
JH
2251 if (truncate(name, len) < 0)
2252 result = 0;
cbdc8872 2253#else
d05c1ba0 2254 {
7452cf6a 2255 const int tmpfd = PerlLIO_open(name, O_RDWR);
d05c1ba0 2256
7452cf6a 2257 if (tmpfd < 0)
cbdc8872 2258 result = 0;
d05c1ba0
JH
2259 else {
2260 if (my_chsize(tmpfd, len) < 0)
2261 result = 0;
2262 PerlLIO_close(tmpfd);
2263 }
cbdc8872 2264 }
a0d0e21e 2265#endif
d05c1ba0 2266 }
a0d0e21e 2267
d05c1ba0
JH
2268 if (result)
2269 RETPUSHYES;
2270 if (!errno)
93189314 2271 SETERRNO(EBADF,RMS_IFI);
d05c1ba0
JH
2272 RETPUSHUNDEF;
2273 }
a0d0e21e
LW
2274}
2275
a0d0e21e
LW
2276PP(pp_ioctl)
2277{
97aff369 2278 dVAR; dSP; dTARGET;
7452cf6a 2279 SV * const argsv = POPs;
1df70142 2280 const unsigned int func = POPu;
e1ec3a88 2281 const int optype = PL_op->op_type;
159b6efe 2282 GV * const gv = MUTABLE_GV(POPs);
4608196e 2283 IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2284 char *s;
324aa91a 2285 IV retval;
a0d0e21e 2286
748a9306 2287 if (!io || !argsv || !IoIFP(io)) {
51087808 2288 report_evil_fh(gv);
93189314 2289 SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
a0d0e21e
LW
2290 RETPUSHUNDEF;
2291 }
2292
748a9306 2293 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2294 STRLEN len;
324aa91a 2295 STRLEN need;
748a9306 2296 s = SvPV_force(argsv, len);
324aa91a
HF
2297 need = IOCPARM_LEN(func);
2298 if (len < need) {
2299 s = Sv_Grow(argsv, need + 1);
2300 SvCUR_set(argsv, need);
a0d0e21e
LW
2301 }
2302
748a9306 2303 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW
2304 }
2305 else {
748a9306 2306 retval = SvIV(argsv);
c529f79d 2307 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW
2308 }
2309
ed4b2e6b 2310 TAINT_PROPER(PL_op_desc[optype]);
a0d0e21e
LW
2311
2312 if (optype == OP_IOCTL)
2313#ifdef HAS_IOCTL
76e3520e 2314 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2315#else
cea2e8a9 2316 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW
2317#endif
2318 else
c214f4ad
B
2319#ifndef HAS_FCNTL
2320 DIE(aTHX_ "fcntl is not implemented");
2321#else
55497cff 2322#if defined(OS2) && defined(__EMX__)
760ac839 2323 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2324#else
760ac839 2325 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2326#endif
6652bd42 2327#endif
a0d0e21e 2328
6652bd42 2329#if defined(HAS_IOCTL) || defined(HAS_FCNTL)
748a9306
LW
2330 if (SvPOK(argsv)) {
2331 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2332 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
53e06cf0 2333 OP_NAME(PL_op));
748a9306
LW
2334 s[SvCUR(argsv)] = 0; /* put our null back */
2335 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW
2336 }
2337
2338 if (retval == -1)
2339 RETPUSHUNDEF;
2340 if (retval != 0) {
2341 PUSHi(retval);
2342 }
2343 else {
8903cb82 2344 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e 2345 }
4808266b 2346#endif
c214f4ad 2347 RETURN;
a0d0e21e
LW
2348}
2349
2350PP(pp_flock)
2351{
9cad6237 2352#ifdef FLOCK
97aff369 2353 dVAR; dSP; dTARGET;
a0d0e21e 2354 I32 value;
bc37a18f 2355 IO *io = NULL;
760ac839 2356 PerlIO *fp;
7452cf6a 2357 const int argtype = POPi;
159b6efe 2358 GV * const gv = (MAXARG == 0) ? PL_last_in_gv : MUTABLE_GV(POPs);
16d20bd9 2359
bc37a18f
RG
2360 if (gv && (io = GvIO(gv)))
2361 fp = IoIFP(io);
2362 else {
4608196e 2363 fp = NULL;
bc37a18f
RG
2364 io = NULL;
2365 }
0bcc34c2 2366 /* XXX Looks to me like io is always NULL at this point */
a0d0e21e 2367 if (fp) {
68dc0745 2368 (void)PerlIO_flush(fp);
76e3520e 2369 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2370 }
cb50131a 2371 else {
51087808 2372 report_evil_fh(gv);
a0d0e21e 2373 value = 0;
93189314 2374 SETERRNO(EBADF,RMS_IFI);
cb50131a 2375 }
a0d0e21e
LW
2376 PUSHi(value);
2377 RETURN;
2378#else
cea2e8a9 2379 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW
2380#endif
2381}
2382
2383/* Sockets. */
2384
2385PP(pp_socket)
2386{
a0d0e21e 2387#ifdef HAS_SOCKET
97aff369 2388 dVAR; dSP;
7452cf6a
AL
2389 const int protocol = POPi;
2390 const int type = POPi;
2391 const int domain = POPi;
159b6efe 2392 GV * const gv = MUTABLE_GV(POPs);
7452cf6a 2393 register IO * const io = gv ? GvIOn(gv) : NULL;
a0d0e21e
LW
2394 int fd;
2395
c289d2f7 2396 if (!gv || !io) {
51087808 2397 report_evil_fh(gv);
5ee74a84 2398 if (io && IoIFP(io))
c289d2f7 2399 do_close(gv, FALSE);
93189314 2400 SETERRNO(EBADF,LIB_INVARG);
a0d0e21e
LW
2401 RETPUSHUNDEF;
2402 }
2403
57171420
BS
2404 if (IoIFP(io))
2405 do_close(gv, FALSE);
2406
a0d0e21e 2407 TAINT_PROPER("socket");
6ad3d225 2408 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW
2409 if (fd < 0)
2410 RETPUSHUNDEF;
460c8493
IZ
2411 IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2412 IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
50952442 2413 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2414 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW
2415 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2416 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2417 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW
2418 RETPUSHUNDEF;
2419 }
8d2a6795
GS
2420#if defined(HAS_FCNTL) && defined(F_SETFD)
2421 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2422#endif
a0d0e21e 2423
d5ff79b3
OF
2424#ifdef EPOC
2425 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2426#endif
2427
a0d0e21e
LW
2428 RETPUSHYES;
2429#else
cea2e8a9 2430 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW
2431#endif
2432}
2433
2434PP(pp_sockpair)
2435{
c95c94b1 2436#if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
97aff369 2437 dVAR; dSP;
7452cf6a
AL
2438 const int protocol = POPi;
2439 const int type = POPi;
2440 const int domain = POPi;
159b6efe
NC
2441 GV * const gv2 = MUTABLE_GV(POPs);
2442 GV * const gv1 = MUTABLE_GV(POPs);
7452cf6a
AL
2443 register IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
2444 register IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
a0d0e21e
LW
2445 int fd[2];
2446
c289d2f7 2447 if (!gv1 || !gv2 || !io1 || !io2) {
51087808
NC
2448 if (!gv1 || !io1)
2449 report_evil_fh(gv1);
2450 if (!gv2 || !io2)
2451 report_evil_fh(gv2);
c289d2f7 2452 }
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
c289d2f7 2533 if (!gv || !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 }