local-lib5/lib/perl5/Catalyst/Plugin/StackTrace.pm

   1 package Catalyst::Plugin::StackTrace;
   2
   3 use strict;
   4 use warnings;
   5 use 5.008001;
   6 use base qw/Class::Accessor::Fast/;
   7 use Devel::StackTrace;
   8 use HTML::Entities;
   9 use Scalar::Util qw/blessed/;
  10 use MRO::Compat;
  11
  12 our $VERSION = '0.11';
  13
  14 __PACKAGE__->mk_accessors('_stacktrace');
  15
  16 sub execute {
  17     my $c = shift;
  18
  19
  20     my $conf = $c->config->{stacktrace};
  21
  22     return $c->next::method(@_)
  23       unless defined $conf->{enable} && $conf->{enable}
  24           || !defined $conf->{enable} && $c->debug;
  25
  26     local $SIG{__DIE__} = sub {
  27         my $error = shift;
  28
  29         # ignore if the error is a Tree::Simple object
  30         # because FindByUID uses an internal die several times per request
  31         return if ( blessed($error) && $error->isa('Tree::Simple') );
  32
  33         my $ignore_package = [ 'Catalyst::Plugin::StackTrace' ];
  34         my $ignore_class   = [];
  35
  36         if ( $c->config->{stacktrace}->{verbose} < 2 ) {
  37             $ignore_package = [
  38                 qw/
  39                    Catalyst
  40                    Catalyst::Action
  41                    Catalyst::Base
  42                    Catalyst::Dispatcher
  43                    Catalyst::Plugin::StackTrace
  44                    Catalyst::Plugin::Static::Simple
  45                    NEXT
  46                    Class::C3
  47                    main
  48                   /
  49             ];
  50             $ignore_class = [
  51                 qw/
  52                    Catalyst::Engine
  53                   /
  54             ];
  55         }
  56
  57         # Devel::StackTrace dies sometimes, and dying in $SIG{__DIE__} does bad
  58         # things
  59         my $trace;
  60         {
  61             local $@;
  62             eval {
  63                 $trace = Devel::StackTrace->new(
  64                     ignore_package   => $ignore_package,
  65                     ignore_class     => $ignore_class,
  66                 );
  67             };
  68         }
  69         die $error unless defined $trace;
  70
  71         my @frames = $c->config->{stacktrace}->{reverse} ?
  72         reverse $trace->frames : $trace->frames;
  73
  74         my $keep_frames = [];
  75         for my $frame ( @frames ) {
  76             # only display frames from the user's app unless verbose
  77             if ( !$c->config->{stacktrace}->{verbose} ) {
  78                 my $app = "$c";
  79                 $app =~ s/=.*//;
  80                 next unless $frame->package =~ /^$app/;
  81             }
  82
  83             push @{$keep_frames}, {
  84                 pkg  => $frame->package,
  85                 file => $frame->filename,
  86                 line => $frame->line,
  87             };
  88         }
  89         $c->_stacktrace( $keep_frames );
  90
  91         die $error;
  92     };
  93
  94     return $c->next::method(@_);
  95 }
  96
  97 sub finalize_error {
  98     my $c = shift;
  99
 100     $c->next::method(@_);
 101
 102     if ( $c->debug ) {
 103         return unless ref $c->_stacktrace eq 'ARRAY';
 104
 105         # insert the stack trace into the error screen above the "infos" div
 106         my $html = qq{
 107             <style type="text/css">
 108                 div.trace {
 109                     background-color: #eee;
 110                     border: 1px solid #575;
 111                 }
 112                 div#stacktrace table {
 113                     width: 100%;
 114                 }
 115                 div#stacktrace th, td {
 116                     padding-right: 1.5em;
 117                     text-align: left;
 118                 }
 119                 div#stacktrace .line {
 120                     color: #000;
 121                     font-weight: strong;
 122                 }
 123             </style>
 124             <div class="trace error">
 125             <h2><a href="#" onclick="toggleDump('stacktrace'); return false">Stack Trace</a></h2>
 126                 <div id="stacktrace">
 127                     <table>
 128                        <tr>
 129                            <th>Package</th>
 130                            <th>Line   </th>
 131                            <th>File   </th>
 132                        </tr>
 133         };
 134         for my $frame ( @{$c->_stacktrace} ) {
 135
 136             # clean up the common filename of
 137             # .../MyApp/script/../lib/...
 138             if ( $frame->{file} =~ /../ ) {
 139                 $frame->{file} =~ s{script/../}{};
 140             }
 141
 142             my $pkg  = encode_entities $frame->{pkg};
 143             my $line = encode_entities $frame->{line};
 144             my $file = encode_entities $frame->{file};
 145             my $code_preview = _print_context(
 146                 $frame->{file},
 147                 $frame->{line},
 148                 $c->config->{stacktrace}->{context}
 149             );
 150
 151             $html .= qq{
 152                        <tr>
 153                            <td>$pkg</td>
 154                            <td>$line</td>
 155                            <td>$file</td>
 156                        </tr>
 157                        <tr>
 158                            <td colspan="3"><pre><p><code class="error">$code_preview</code></p></pre></td>
 159                        </tr>
 160             };
 161         }
 162         $html .= qq{
 163                     </table>
 164                 </div>
 165             </div>
 166         };
 167
 168         $c->res->{body} =~ s{<div class="infos">}{$html<div class="infos">};
 169     }
 170 }
 171
 172 sub setup {
 173     my $c = shift;
 174
 175     $c->next::method(@_);
 176
 177     $c->config->{stacktrace}->{context} ||= 3;
 178     $c->config->{stacktrace}->{verbose} ||= 0;
 179 }
 180
 181 sub _print_context {
 182     my ( $file, $linenum, $context ) = @_;
 183
 184     my $code;
 185     if ( -f $file ) {
 186         my $start = $linenum - $context;
 187         my $end   = $linenum + $context;
 188         $start = $start < 1 ? 1 : $start;
 189         if ( my $fh = IO::File->new( $file, 'r' ) ) {
 190             my $cur_line = 0;
 191             while ( my $line = <$fh> ) {
 192                 ++$cur_line;
 193                 last if $cur_line > $end;
 194                 next if $cur_line < $start;
 195                 my @tag = $cur_line == $linenum ? ('<strong class="line">', '</strong>') : (q{}, q{});
 196                 $code .= sprintf(
 197                     '%s%5d: %s%s',
 198                         $tag[0],
 199                         $cur_line,
 200                         $line ? encode_entities $line : q{},
 201                         $tag[1],
 202                 );
 203             }
 204         }
 205     }
 206     return $code;
 207 }
 208
 209 1;
 210 __END__
 211
 212 =pod
 213
 214 =head1 NAME
 215
 216 Catalyst::Plugin::StackTrace - Display a stack trace on the debug screen
 217
 218 =head1 SYNOPSIS
 219
 220     use Catalyst qw/-Debug StackTrace/;
 221
 222 =head1 DESCRIPTION
 223
 224 This plugin will enhance the standard Catalyst debug screen by including
 225 a stack trace of your appliation up to the point where the error occurred.
 226 Each stack frame is displayed along with the package name, line number, file
 227 name, and code context surrounding the line number.
 228
 229 This plugin is only active in -Debug mode by default, but can be enabled by
 230 setting the C<enable> config option.
 231
 232 =head1 CONFIGURATION
 233
 234 Configuration is optional and is specified in MyApp->config->{stacktrace}.
 235
 236 =head2 enable
 237
 238 Allows you forcibly enable or disalbe this plugin, ignoring the current
 239 debug setting. If this option is defined, its value will be used.
 240
 241 =head2 context
 242
 243 The number of context lines of code to display on either side of the stack
 244 frame line.  Defaults to 3.
 245
 246 =head2 reverse
 247
 248 By default, the stack frames are shown in from "top" to "bottom"
 249 (newest to oldest). Enabling this option reverses the stack frames so they will
 250 be displayed "bottom" to "top", or from the callers perspective.
 251
 252 =head2 verbose
 253
 254 This option sets the amount of stack frames you want to see in the stack
 255 trace.  It defaults to 0, meaning only frames from your application's
 256 namespace are shown.  You can use levels 1 and 2 for deeper debugging.
 257
 258 If set to 1, the stack trace will include frames from packages outside of
 259 your application's namespace, but not from most of the Catalyst internals.
 260 Packages ignored at this level include:
 261
 262     Catalyst
 263     Catalyst::Action
 264     Catalyst::Base
 265     Catalyst::Dispatcher
 266     Catalyst::Engine::*
 267     Catalyst::Plugin::StackTrace
 268     Catalyst::Plugin::Static::Simple
 269     NEXT
 270     main
 271
 272 If set to 2, the stack trace will include frames from everything except this
 273 module.
 274
 275 =head1 INTERNAL METHODS
 276
 277 The following methods are extended by this plugin.
 278
 279 =over 4
 280
 281 =item execute
 282
 283 In execute, we create a local die handler to generate the stack trace.
 284
 285 =item finalize_error
 286
 287 In finalize_error, we inject the stack trace HTML into the debug screen below
 288 the error message.
 289
 290 =item setup
 291
 292 =back
 293
 294 =head1 SEE ALSO
 295
 296 L<Catalyst>
 297
 298 =head1 AUTHORS
 299
 300 Andy Grundman, <andy@hybridized.org>
 301
 302 Matt S. Trout, <mst@shadowcatsystems.co.uk>
 303
 304 =head1 THANKS
 305
 306 The authors of L<CGI::Application::Plugin::DebugScreen>, from which a lot of
 307 code was used.
 308
 309 =head1 COPYRIGHT
 310
 311 Copyright (c) 2005 - 2009
 312 the Catalyst::Plugin::StackTrace L</AUTHORS>
 313 as listed above.
 314
 315 =head1 LICENSE
 316
 317 This program is free software, you can redistribute it and/or modify it
 318 under the same terms as Perl itself.
 319
 320 =cut