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