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