CGI::AppでのDebugScreen悩みどころ

id:tokuhiromさん

id:kazeburoさん
のご意見を参考にさせていただき、少し手を入れてみました。

確かに前のコードだとeval-blockを意図して使用している場合に問題ありでした、
で、ちょっと試したコードです。


sub import {
my $self = shift;
my $caller = scalar caller;
no strict 'refs';
$caller->add_callback( 'init', sub{
my $self = shift;
$SIG{__DIE__} = sub{
push @{$self->{__stacktrace}},[Devel::StackTrace->new(ignore_package=>[qw/CGI::Application::Plugin::DebugScreen Carp CGI::Carp/])->frames];
die @_; # rethrow
};
*{"$caller\::report"} = \&debug_report;
});
$caller->add_callback( 'error', sub{
my $self = shift;
$self->report(@_);
});
}
sub debug_report{
my $self = shift;
my $desc = shift;
my $url = $self->query->url;
my $title = ref $self || $self;
my $stacks = $self->{__stacktrace}[0];
my @stacktraces;
for my $stack ( @{$stacks} ) {
my %s;
$s{package} = exists $stack->{pkg} ? $stack->{pkg} : $stack->{package};
$s{filename} = $stack->{file} ? $stack->{file} : $stack->{filename};
$s{package} = html_escape($s{package});
$s{filename} = html_escape($s{filename});
$s{line} = html_escape($stack->{line});
$s{code_preview} = print_context($s{filename},$s{line});
push @stacktraces, \%s;
}
"HTML::Template"->use or die qq[Couldn't load HTML::Template.pm, "$@"];
my $t = HTML::Template->new(
scalarref => \$TEMPLATE,
die_on_bad_params => 0,
);
$t->param(
title => html_escape($title),
url => html_escape($url),
desc => html_escape($desc),
stacktrace => \@stacktraces,
);
$self->header_props( -type => 'text/html' );
my $headers = $self->_send_headers();
print $headers.$t->output;
}

id:kazeburoさんがおっしゃるようにprerunやpostrunでのdieは補足できないですね。
これはかなり致命的ですよね。

あと、id:charsbarさんのご意見からも、
テンプレートエンジンのデフォルトサポートはCGI::AppデフォルトのHTML::Templateだけでよいかなと。
テンプレートエンジンを使い分けできるようにしておけばよいかなと少し考えております。

id:MARKSTOSさんのバグ情報はまだちゃんと見ていません^^;

う〜む。スマートでないなぁ。。。


(追記)
id:naoyaさんがおっしゃってるのはこういうことかな?
Devel::StarckTrace インスタンスを保持ではないですが。


eval {
$SIG{__DIE__} = sub{
push @{$self->{__stacktrace}},[Devel::StackTrace->new(ignore_package=>[qw/CGI::Application::Plugin::DebugScreen Carp CGI::Carp/])->frames];
die @_; # rethrow
};
};
if ( $@ ) {
$self->report(@_);
die;
}