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