CGI::AppでのDebugScreen
空前の大ブームであるDebugScreenですが、
CGI::Appのプラグインにしてみました。
ほとんどMF::TokuLogさんとnipotanさんのコードをパクリましたが＾＾；
package CGI::Application::Plugin::DebugScreen;
use strict;
use warnings;
use base 'Exporter';
use Template;
use Devel::StackTrace;
use IO::File;
our $VERSION = '0.01';
our @EXPORT = qw/ debug /;
our $TEMPLATE = q{
<html lang="ja">
<head>
<title>Error in [% title | html %]</title>
<style type="text/css">
body {
font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
Tahoma, Arial, helvetica, sans-serif;
color: #000;
background-color: #F5131A;
margin: 0px;
padding: 0px;
}
:link, :link:hover, :visited, :visited:hover {
color: #000;
}
div.box {
position: relative;
background-color: #fff;
border: 1px solid #aaa;
padding: 4px;
margin: 10px;
-moz-border-radius: 10px;
}
div.infos {
background-color: #fff;
border: 3px solid #FBEE1A;
padding: 8px;
margin: 4px;
margin-bottom: 10px;
-moz-border-radius: 10px;
}
h1 {
margin: 0;
}
h2 {
margin-top: 0;
margin-bottom: 10px;
font-size: medium;
font-weight: bold;
text-decoration: underline;
}
div.url {
font-size: x-small;
}
pre {
font-size: .8em;
line-height: 120%;
font-family: 'Courier New', Courier, monospace;
background-color: #fee;
color: #333;
border: 1px dotted #000;
padding: 5px;
margin: 8px;
width: 90%;
}
pre b {
font-weight: bold;
color: #000;
background-color: #f99;
}
</style>
</head>
<body>
<div class="box">
<h1>[% title | html %]</h1>
<div class="url">[% pages.current_url | html %]</div>
<div class="infos">
[% desc | html %]<br />
</div>
<div class="infos">
<h2>StackTrace</h2>
<table>
<tr>
<th>Package</th>
<th>Line </th>
<th>File </th>
</tr>
[% FOR s IN stacktrace -%]
<tr>
<td>[% (s.pkg || s.package) | html %]</td>
<td>[% s.line | html %]</td>
<td>[% filename = (s.file || s.filename) %][% filename | html %]</td>
</tr>
<tr>
<td colspan="3">[% code_preview = context(filename, s.line) %][% IF code_preview %]<pre>[% code_preview %]</pre>[% END %]</td>
</tr>
[%- END %]
</table>
</div>
</div>
</body>
</html>
};
sub import {
my $caller = scalar(caller);
$caller->add_callback( 'prerun', \&debug );
goto &Exporter::import;
}
sub debug {
my $self = shift;
$SIG{__DIE__} = \&debug_report;
my $rm = $self->{__CURRENT_RUNMODE};
my %rmodes = ($self->run_modes());
my $rmeth;
my $autoload_mode = 0;
if (exists($rmodes{$rm})) {
$rmeth = $rmodes{$rm};
} else {
unless (exists($rmodes{'AUTOLOAD'})) {
die "No such run mode '$rm'";
}
$rmeth = $rmodes{'AUTOLOAD'};
$autoload_mode = 1;
}
my $body = $autoload_mode ? $self->$rmeth($rm) : $self->$rmeth();
return;
}
sub debug_report {
my $desc = shift;
my $caller = scalar(caller);
my $vars = {
desc => $desc,
title => $caller,
context => \&print_context,
};
$vars->{stacktrace} = [Devel::StackTrace->new->frames];
my $t = Template->new;
my $output;
$t->process(\$TEMPLATE, $vars, \$output);
my $headers = "Content-type: text/html;\n\n";
print $headers.$output;
exit;
}
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(<b> </b>) : ();
$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;
こんなんです。
仕組みとしてはCGI::APPのprerunで、runmodeのメソッドを実行させてます。
なぜかといふと、CGI::APP上での普通のrunmodeの実行はevalされてるから、
dieをつかめんとです。
オイラの力ではこれが限界っす。
他にいい方法ないっすかねぇ。
サンプル画像を上げておきます。
これでほぼパクリってのがばれるｗ
