package CGI::Application::Plugin::DebugScreen; use strict; use warnings; use Template; use Devel::StackTrace; use IO::File; our $VERSION = '0.01'; our $TEMPLATE = q{ Error in [% title | html %]

[% title | html %]

[% pages.current_url | html %]
[% desc | html %]

StackTrace

[% FOR s IN stacktrace -%] [%- END %]
Package Line File
[% (s.pkg || s.package) | html %] [% s.line | html %] [% filename = (s.file || s.filename) %][% filename | html %]
[% code_preview = context(filename, s.line) %][% IF code_preview %]
[% code_preview %]
[% END %]
}; sub import { my $caller = scalar caller; $caller->add_callback( 'init', sub{ my $self = shift; $caller::SIG{__DIE__} = sub{ $self->debug_report(@_); #die @_; }; }); no strict 'refs'; *{"$caller\::debug_report"} = \&debug_report; } sub debug_report{ my $self = shift; my $desc = shift; my $vars = { desc => $desc, title => ref $self || $self, context => \&print_context, }; $vars->{stacktrace} = [Devel::StackTrace->new(ignore_package=>[qw/CGI::Application::Plugin::DebugScreen Carp/])->frames]; my $t = Template->new; my $output; $t->process(\$TEMPLATE, $vars, \$output); $self->header_props( -type => 'text/html' ); my $headers = $self->_send_headers(); print $headers.$output; } sub print_context { my($file, $linenum) = @_; my $code; if (-f $file) { my $start = $linenum - 3; my $end = $linenum + 3; $start = $start < 1 ? 1 : $start; if (my $fh = IO::File->new($file, 'r')) { my $cur_line = 0; while (my $line = <$fh>) { ++$cur_line; last if $cur_line > $end; next if $cur_line < $start; my @tag = $cur_line == $linenum ? qw( ) : ("",""); $code .= sprintf( '%s%5d: %s%s', $tag[0], $cur_line, html_escape($line), $tag[1], ); } } } return $code; } sub html_escape { my $str = shift; $str =~ s/&/&/g; $str =~ s//>/g; $str =~ s/"/"/g; return $str; } 1;