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