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
Package |
Line |
File |
[% FOR s IN stacktrace -%]
[% (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 %] |
[%- 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;
$str =~ s/"/"/g;
return $str;
}
1;