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