Better stacktrace

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

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;
 }
 

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 = '<pre class="error">' . _html_encode($message) . '</pre>';
+    my $html = '<pre class="error">' . _html_encode($message) . "</pre>\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|<div class="title">| . "$file around line $line" . "</div>";
-
-    $backtrace .= qq|<pre class="content">|;
+    $html .= qq|<div class="title">$file around line $line</div>|;
 
-    $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|<pre class="content"><table class="context">\n|;
+    for my $l ($start .. $stop) {
+        chomp $lines[$l - 1];
 
-        if ( $l == $line ) {
-            $backtrace
-              .= qq|<span class="nu">|
-              . tabulate( $l + 1, $stop + 1 )
-              . qq|</span> <span style="color: red;">|
-              . _html_encode( $lines[$l] )
-              . "</span>\n";
-        }
-        else {
-            $backtrace
-              .= qq|<span class="nu">|
-              . tabulate( $l + 1, $stop + 1 )
-              . "</span> "
-              . _html_encode( $lines[$l] ) . "\n";
-        }
+        $html .= $l == $line ? '<tr class="errline">' : '<tr>';
+        $html .= "<th>$l</th><td>" . _html_encode($lines[$l - 1]) . "</td></tr>\n";
     }
-    $backtrace .= "</pre>";
-
-    return $backtrace;
-}
+    $html .= "</table></pre>\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 = "<span class=\"key\">$html</span>(";
+            $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 .= '<span class="errline">'.$frame->filename.'</span> line <span class="errline">'.$frame->line.'</span>';
+        push @stack, $html;
     }
-
-    return join( "\n", reverse(@stack) );
+    return join "\n", @stack;
 }
 
 # private

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 {