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