diff options
| -rw-r--r-- | pp_ctl.c | 17 | ||||
| -rwxr-xr-x | t/op/tiehandle.t | 17 | ||||
| -rw-r--r-- | util.c | 16 |
3 files changed, 47 insertions, 3 deletions
@@ -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 7ae33514c9..257a613958 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); +} + @@ -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; |