summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDaniel Chetlin <daniel@chetlin.com>2000-10-02 07:53:27 -0700
committerJarkko Hietaniemi <jhi@iki.fi>2000-10-02 23:32:38 +0000
commit01bb7c6d67bc951562ed98068eba189cadd42374 (patch)
tree8a690ec57aeca12f1e60a5d90b22f5efaa807a7d
parentb38af7adab46822ec7c92d231d7fbb058dc22c4c (diff)
downloadperl-01bb7c6d67bc951562ed98068eba189cadd42374.tar.gz
Fix aliasing of tied filehandles
Message-ID: <20001002145327.C1617@ilmd> p4raw-id: //depot/perl@7110
-rw-r--r--perl.h1
-rw-r--r--pp_hot.c3
-rwxr-xr-xt/op/tiehandle.t18
3 files changed, 21 insertions, 1 deletions
diff --git a/perl.h b/perl.h
index 5661851489..0b5c6ea3ea 100644
--- a/perl.h
+++ b/perl.h
@@ -2056,6 +2056,7 @@ Gid_t getegid (void);
#ifndef Perl_error_log
# define Perl_error_log (PL_stderrgv \
+ && GvIOp(PL_stderrgv) \
&& IoOFP(GvIOp(PL_stderrgv)) \
? IoOFP(GvIOp(PL_stderrgv)) \
: PerlIO_stderr())
diff --git a/pp_hot.c b/pp_hot.c
index 17710d5e4f..7d395141e8 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -377,6 +377,7 @@ PP(pp_print)
else
gv = PL_defoutgv;
if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
+ had_magic:
if (MARK == ORIGMARK) {
/* If using default handle then we need to make space to
* pass object as 1st arg, so move other args up ...
@@ -400,6 +401,8 @@ PP(pp_print)
}
if (!(io = GvIO(gv))) {
dTHR;
+ if ((GvEGV(gv)) && (mg = SvTIED_mg((SV*)GvEGV(gv),'q')))
+ goto had_magic;
if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
report_evil_fh(gv, io, PL_op->op_type);
SETERRNO(EBADF,RMS$_IFI);
diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index d7e6a78baf..b04bdb7897 100755
--- a/t/op/tiehandle.t
+++ b/t/op/tiehandle.t
@@ -77,7 +77,7 @@ package main;
use Symbol;
-print "1..29\n";
+print "1..33\n";
my $fh = gensym;
@@ -149,3 +149,19 @@ ok($data eq "qwerty");
@expect = (CLOSE => $ob);
$r = close $fh;
ok($r == 5);
+
+# Does aliasing work with tied FHs?
+*ALIAS = *$fh;
+@expect = (PRINT => $ob,"some","text");
+$r = print ALIAS @expect[2,3];
+ok($r == 1);
+
+{
+ use warnings;
+ # Special case of aliasing STDERR, which used
+ # to dump core when warnings were enabled
+ *STDERR = *$fh;
+ @expect = (PRINT => $ob,"some","text");
+ $r = print STDERR @expect[2,3];
+ ok($r == 1);
+}