diff --git a/dist.ini b/dist.ini index 582adab15..5ea55c9dc 100644 --- a/dist.ini +++ b/dist.ini @@ -55,6 +55,7 @@ Moo::Role = 0 Role::Tiny = 2.000000 MooX::Types::MooseLike = 0 Carp = 0 +Devel::StackTrace = 0 Digest::SHA = 0 Exporter = 5.57 Encode = 0 diff --git a/lib/Dancer2/Core/App.pm b/lib/Dancer2/Core/App.pm index 46394b4ef..e959853c2 100644 --- a/lib/Dancer2/Core/App.pm +++ b/lib/Dancer2/Core/App.pm @@ -9,6 +9,7 @@ use Return::MultiLevel (); use Safe::Isa; use Sub::Quote; use File::Spec; +use Devel::StackTrace; use Plack::Middleware::FixMissingBodyInRedirect; use Plack::Middleware::Head; @@ -1394,9 +1395,18 @@ sub _dispatch_route { return $self->_prep_response( $response ); } + my $trace; $response = eval { + local $SIG{__DIE__} = sub { + my $end_trace; + $trace = Devel::StackTrace->new( + skip_frames => 1, + frame_filter => sub { $end_trace = 1 if $_[0]{caller}[0] eq 'Dancer2::Core::Route'; !$end_trace }, + ); + die @_; + }; $route->execute($self) - } or return $self->response_internal_error($@); + } or return $self->response_internal_error($@, $trace); return $response; } @@ -1419,7 +1429,7 @@ sub _prep_response { } sub response_internal_error { - my ( $self, $error ) = @_; + my ( $self, $error, $trace ) = @_; $self->log( error => "Route exception: $error" ); $self->execute_hook( 'core.app.route_exception', $self, $error ); @@ -1428,9 +1438,10 @@ sub response_internal_error { local $Dancer2::Core::Route::RESPONSE = $self->response; return Dancer2::Core::Error->new( - app => $self, - status => 500, - exception => $error, + app => $self, + status => 500, + exception => $error, + (stack_trace => $trace)x!! $trace, )->throw; } diff --git a/lib/Dancer2/Core/Error.pm b/lib/Dancer2/Core/Error.pm index 451e1e455..6707f66fa 100644 --- a/lib/Dancer2/Core/Error.pm +++ b/lib/Dancer2/Core/Error.pm @@ -7,6 +7,7 @@ use Dancer2::Core::Types; use Dancer2::Core::HTTP; use Data::Dumper; use Dancer2::FileUtils qw/path open_file/; +use Devel::StackTrace; use Sub::Quote; has app => ( @@ -230,6 +231,13 @@ has content => ( builder => '_build_content', ); +has stack_trace => ( + is => 'ro', + isa => InstanceOf['Devel::StackTrace'], + lazy => 1, + default => sub { Devel::StackTrace->new(ignore_package => __PACKAGE__) }, +); + sub _build_content { my $self = shift; @@ -327,64 +335,37 @@ sub backtrace { } $message ||= 'Wooops, something went wrong'; - $message = '
' . _html_encode($message) . '
'; + my $html = '
' . _html_encode($message) . "
\n"; # the default perl warning/error pattern - my ( $file, $line ) = ( $message =~ /at (\S+) line (\d+)/ ); - + my ($file, $line) = $message =~ /at (\S+) line (\d+)/; # the Devel::SimpleTrace pattern - ( $file, $line ) = ( $message =~ /at.*\((\S+):(\d+)\)/ ) - unless $file and $line; + ($file, $line) = $message =~ /at.*\((\S+):(\d+)\)/ unless $file and $line; # no file/line found, cannot open a file for context - return $message unless ( $file and $line ); + return $html unless $file and $line; # file and line are located, let's read the source Luke! - my $fh = eval { open_file( '<', $file ) } or return $message; + my $fh = eval { open_file('<', $file) } or return $html; my @lines = <$fh>; close $fh; - my $backtrace = $message; - - $backtrace - .= qq|
| . "$file around line $line" . "
"; - - $backtrace .= qq|
|;
+    $html .= qq|
$file around line $line
|;
 
-    $line--;
-    my $start = ( ( $line - 3 ) >= 0 ) ? ( $line - 3 ) : 0;
-    my $stop =
-      ( ( $line + 3 ) < scalar(@lines) ) ? ( $line + 3 ) : scalar(@lines);
+    # get 5 lines of context
+    my $start = $line - 5 > 1 ? $line - 5 : 1;
+    my $stop = $line + 5 < @lines ? $line + 5 : @lines;
 
-    for ( my $l = $start; $l <= $stop; $l++ ) {
-        chomp $lines[$l];
+    $html .= qq|
\n|;
+    for my $l ($start .. $stop) {
+        chomp $lines[$l - 1];
 
-        if ( $l == $line ) {
-            $backtrace
-              .= qq||
-              . tabulate( $l + 1, $stop + 1 )
-              . qq||
-              . _html_encode( $lines[$l] )
-              . "\n";
-        }
-        else {
-            $backtrace
-              .= qq||
-              . tabulate( $l + 1, $stop + 1 )
-              . " "
-              . _html_encode( $lines[$l] ) . "\n";
-        }
+        $html .= $l == $line ? '' : '';
+        $html .= "\n";
     }
-    $backtrace .= "";
-
-    return $backtrace;
-}
+    $html .= "
 
$l" . _html_encode($lines[$l - 1]) . "
\n";
 
-sub tabulate {
-    my ( $number, $max ) = @_;
-    my $len = length($max);
-    return $number if length($number) == $len;
-    return " $number";
+    return $html;
 }
 
 sub dumper {
@@ -434,12 +415,33 @@ sub get_caller {
     my ($self) = @_;
     my @stack;
 
-    my $deepness = 0;
-    while ( my ( $package, $file, $line ) = caller( $deepness++ ) ) {
-        push @stack, "$package in $file l. $line";
+    while (my $frame = $self->stack_trace->next_frame) {
+        my $html;
+        unless (@stack) {
+            $html = 'Trace begun at ';
+        } else {
+            if (my $eval = $frame->evaltext) {
+                if ($frame->is_require) {
+                    $html = 'require '.$eval;
+                } else {
+                    $eval =~ s/([\\\'])/\\$1/g;
+                    $html = "eval '$eval'";
+                }
+            } else {
+                $html = $frame->subroutine;
+                $html = 'eval {...}' if $html eq '(eval)';
+            }
+            $html = "$html(";
+            $html .= join ', ', map {
+                my $arg = Data::Dumper->new([$_])->Terse(1)->Indent(0)->Maxdepth(1)->Useqq(1)->Dump;
+                length $arg > 50 ? substr($arg, 0, 48).'...' : $arg;
+            } $frame->args;
+            $html .= ') called at ';
+        }
+        $html .= ''.$frame->filename.' line '.$frame->line.'';
+        push @stack, $html;
     }
-
-    return join( "\n", reverse(@stack) );
+    return join "\n", @stack;
 }
 
 # private
diff --git a/share/skel/public/css/error.css b/share/skel/public/css/error.css
index 9cff07795..8a5e83173 100644
--- a/share/skel/public/css/error.css
+++ b/share/skel/public/css/error.css
@@ -54,9 +54,23 @@ div.title {
     padding-left: 10px;
 }
 
-pre.content span.nu {
+table.context {
+    border-spacing: 0;
+}
+
+table.context th, table.context td {
+    padding: 0;
+}
+
+table.context th {
     color: #889;
-    margin-right: 10px;
+    font-weight: normal;
+    padding-right: 15px;
+    text-align: right;
+}
+
+.errline {
+    color: red;
 }
 
 pre.error {