package Catalyst::Plugin::StackTrace; use 5.008001; use Moose; with 'MooseX::Emulate::Class::Accessor::Fast'; use Devel::StackTrace; use HTML::Entities; use Scalar::Util qw/blessed/; use MRO::Compat; use namespace::autoclean; our $VERSION = '0.12'; __PACKAGE__->mk_accessors('_stacktrace'); sub execute { my $c = shift; my $conf = $c->config->{stacktrace}; return $c->next::method(@_) unless defined $conf->{enable} && $conf->{enable} || !defined $conf->{enable} && $c->debug; local $SIG{__DIE__} = sub { my $error = shift; # ignore if the error is a Tree::Simple object # because FindByUID uses an internal die several times per request return if ( blessed($error) && $error->isa('Tree::Simple') ); my $ignore_package = [ 'Catalyst::Plugin::StackTrace' ]; my $ignore_class = []; if ( $c->config->{stacktrace}->{verbose} < 2 ) { $ignore_package = [ qw/ Catalyst Catalyst::Action Catalyst::Base Catalyst::Dispatcher Catalyst::Plugin::StackTrace Catalyst::Plugin::Static::Simple NEXT Class::C3 main / ]; $ignore_class = [ qw/ Catalyst::Engine / ]; } # Devel::StackTrace dies sometimes, and dying in $SIG{__DIE__} does bad # things my $trace; { local $@; eval { $trace = Devel::StackTrace->new( ignore_package => $ignore_package, ignore_class => $ignore_class, ); }; } die $error unless defined $trace; my @frames = $c->config->{stacktrace}->{reverse} ? reverse $trace->frames : $trace->frames; my $keep_frames = []; for my $frame ( @frames ) { # only display frames from the user's app unless verbose if ( !$c->config->{stacktrace}->{verbose} ) { my $app = "$c"; $app =~ s/=.*//; next unless $frame->package =~ /^$app/; } push @{$keep_frames}, { pkg => $frame->package, file => $frame->filename, line => $frame->line, }; } $c->_stacktrace( $keep_frames ); die $error; }; return $c->next::method(@_); } sub finalize_error { my $c = shift; $c->next::method(@_); if ( $c->debug ) { return unless ref $c->_stacktrace eq 'ARRAY'; # insert the stack trace into the error screen above the "infos" div my $html = qq{
Package | Line | File |
---|---|---|
$pkg | $line | $file |
|