From 2dde04676ae62e4ba4bd87d6749bae66d1bed890 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Mon, 26 Dec 2011 16:55:35 -0800 Subject: [PATCH] =?utf8?q?Fix=20diagnostic.pm=E2=80=99s=20backtraces?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit Currently a user-defined error message is printed out like this: ----- Uncaught exception from user code: panick: at -e line 1. at -e line 1 main::baz() called at -e line 1 main::bar() called at -e line 1 main::foo() called at -e line 1 ----- Errors generated from perl itself are printed like this: ----- panic: at -e line 1 (#1) (P) An internal error. Uncaught exception from user code: panic: at -e line 1. at -e line 1 main::baz() called at -e line 1 main::bar() called at -e line 1 main::foo() called at -e line 1 ----- By using Carp::confess(), we end up with a screwy backtrace. Some- times it just ends up repeating the error and line number: ----- panic: at -e line 1 (#1) (P) An internal error. Uncaught exception from user code: panic: at -e line 1. at -e line 1 ----- Uncaught exception from user code: panick at -e line 1. at -e line 1 ----- This commit cleans these up to print like this: ----- Uncaught exception from user code: panick: at -e line 1. main::baz() called at -e line 1 main::bar() called at -e line 1 main::foo() called at -e line 1 ----- panic: at -e line 1 (#1) (P) An internal error. Uncaught exception from user code: panic: at -e line 1. main::baz() called at -e line 1 main::bar() called at -e line 1 main::foo() called at -e line 1 ----- panic: at -e line 1 (#1) (P) An internal error. Uncaught exception from user code: panic: at -e line 1. ----- Uncaught exception from user code: panick at -e line 1. ----- You might ask: Why not remove the ‘uncaught exception’ message alto- gether after an error description. It’s because the error description is a diagnostic, which only prints once for each error or warning encountered. So you could have eval { die } somewhere else in the code, which causes a description to be printed. And later you have a die() that exits the program, but nothing gets printed. In other words, the description of the message does not replace the error. --- lib/diagnostics.pm | 5 ++++- lib/diagnostics.t | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++---- 2 files changed, 54 insertions(+), 5 deletions(-) diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index dc1a9b0..6c166a3 100644 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -576,7 +576,10 @@ sub death_trap { # Have carp skip over death_trap() when showing the stack trace. local($Carp::CarpLevel) = 1; - confess "Uncaught exception from user code:\n\t$exception"; + die Carp::longmess("__diagnostics__") + =~ s/^__diagnostics__.*?line \d+\.?\n/ + "Uncaught exception from user code:\n\t$exception" + /re; # up we go; where we stop, nobody knows, but i think we die now # but i'm deeply afraid of the &$olddie guy reraising and us getting # into an indirect recursion loop diff --git a/lib/diagnostics.t b/lib/diagnostics.t index df111a8..5e418f6 100644 --- a/lib/diagnostics.t +++ b/lib/diagnostics.t @@ -4,7 +4,7 @@ BEGIN { chdir '..' if -d '../pod' && -d '../t'; @INC = 'lib'; require './t/test.pl'; - plan(11); + plan(15); } BEGIN { @@ -22,10 +22,12 @@ eval { like( $@, qr/^Base class package "I::do::not::exist" is empty/); -# Test for %.0f patterns in perldiag, added in 5.11.0 -close STDERR; -open STDERR, ">", \my $warning +open *whatever, ">", \my $warning or die "Couldn't redirect STDERR to var: $!"; +my $old_stderr = *STDERR{IO}; +*STDERR = *whatever{IO}; + +# Test for %.0f patterns in perldiag, added in 5.11.0 warn('gmtime(nan) too large'); like $warning, qr/\(W overflow\) You called/, '%0.f patterns'; @@ -72,3 +74,47 @@ seek STDERR, 0,0; $warning = ''; warn "syntax error"; like $warning, qr/cybernetic version of 20 questions/s, 'strip S<>'; + +*STDERR = $old_stderr; + +# These tests use a panic under the hope that the description is not likely +# to change. +@runperl_args = ( + switches => [ '-Ilib', '-Mdiagnostics' ], + stderr => 1, + nolib => 1, # -I../lib would go outside the build dir +); +$subs = + "sub foo{bar()}sub bar{baz()}sub baz{die q _panic: gremlins_}foo()"; +is runperl(@runperl_args, prog => $subs), + << 'EOT', 'internal error with backtrace'; +panic: gremlins at -e line 1 (#1) + (P) An internal error. + +Uncaught exception from user code: + panic: gremlins at -e line 1. + main::baz() called at -e line 1 + main::bar() called at -e line 1 + main::foo() called at -e line 1 +EOT +is runperl(@runperl_args, prog => $subs =~ s/panic\K/k/r), + << 'EOU', 'user error with backtrace'; +Uncaught exception from user code: + panick: gremlins at -e line 1. + main::baz() called at -e line 1 + main::bar() called at -e line 1 + main::foo() called at -e line 1 +EOU +is runperl(@runperl_args, prog => 'die q _panic: gremlins_'), + << 'EOV', 'no backtrace from top-level internal error'; +panic: gremlins at -e line 1 (#1) + (P) An internal error. + +Uncaught exception from user code: + panic: gremlins at -e line 1. +EOV +is runperl(@runperl_args, prog => 'die q _panick: gremlins_'), + << 'EOW', 'no backtrace from top-level user error'; +Uncaught exception from user code: + panick: gremlins at -e line 1. +EOW -- 2.7.4