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