From: Audrey Tang <cpan@audreyt.org>
Date: Sun, 17 Feb 2002 19:46:47 +0000 (+0800)
Subject: Tied STDERR should catch messages from warn() and die()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=87582a92947b14e9eada0c156f266b59de2f8406;p=p5sagit%2Fp5-mst-13.2.git

Tied STDERR should catch messages from warn() and die()
Message-ID: <20020217194647.A1410@not.autrijus.org>

p4raw-id: //depot/perl@14727
---

diff --git a/pp_ctl.c b/pp_ctl.c
index 9dbd525..14a48c6 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1224,6 +1224,9 @@ OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
     STRLEN n_a;
+    IO *io;
+    MAGIC *mg;
+
     if (PL_in_eval) {
 	I32 cxix;
 	register PERL_CONTEXT *cx;
@@ -1303,7 +1306,19 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
     }
     if (!message)
 	message = SvPVx(ERRSV, msglen);
-    {
+
+    /* if STDERR is tied, print to it instead */
+    if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
+	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+	dSP; ENTER;
+	PUSHMARK(SP);
+	XPUSHs(SvTIED_obj((SV*)io, mg));
+	XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
+	PUTBACK;
+	call_method("PRINT", G_SCALAR);
+	LEAVE;
+    }
+    else {
 #ifdef USE_SFIO
 	/* SFIO can really mess with your errno */
 	int e = errno;
diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t
index 7ae3351..257a613 100755
--- a/t/op/tiehandle.t
+++ b/t/op/tiehandle.t
@@ -77,7 +77,7 @@ package main;
 
 use Symbol;
 
-print "1..38\n";
+print "1..39\n";
 
 my $fh = gensym;
 
@@ -160,7 +160,7 @@ ok($r == 1);
     use warnings;
     # Special case of aliasing STDERR, which used
     # to dump core when warnings were enabled
-    *STDERR = *$fh;
+    local *STDERR = *$fh;
     @expect = (PRINT => $ob,"some","text");
     $r = print STDERR @expect[2,3];
     ok($r == 1);
@@ -217,3 +217,16 @@ ok($r == 1);
     sub TIEARRAY  {bless {}}
 }
 
+{
+    # warnings should pass to the PRINT method of tied STDERR
+    my @received;
+
+    local *STDERR = *$fh;
+    local *Implement::PRINT = sub { @received = @_ };
+
+    $r = warn("some", "text", "\n");
+    @expect = (PRINT => $ob,"sometext\n");
+
+    Implement::compare(PRINT => @received);
+}
+
diff --git a/util.c b/util.c
index 33dcf19..26b63d0 100644
--- a/util.c
+++ b/util.c
@@ -1356,6 +1356,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
     CV *cv;
     SV *msv;
     STRLEN msglen;
+    IO *io;
+    MAGIC *mg;
 
     msv = vmess(pat, args);
     message = SvPV(msv, msglen);
@@ -1388,6 +1390,20 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args)
 	    return;
 	}
     }
+
+    /* if STDERR is tied, use it instead */
+    if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
+	&& (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
+	dSP; ENTER;
+	PUSHMARK(SP);
+	XPUSHs(SvTIED_obj((SV*)io, mg));
+	XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
+	PUTBACK;
+	call_method("PRINT", G_SCALAR);
+	LEAVE;
+	return;
+    }
+
     {
 	PerlIO *serr = Perl_error_log;