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