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