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