CGI::Carpでド派手なデバッグスクリーンを表示させる（２）

前回のはいささか手抜きが過ぎたので、nekokakさんのCGI::Application::Plugin::DebugScreenを参考にちょろっとブラッシュアップ。いくらなんでもここや本家のような緑系で画面つくるのはエラー画面っぽくないよなあということでCSSはほとんどnekokakさんの(ひいてはid:nipotanさんやid:tokuhiromさんの、ですね。失礼しました)パクリですが、地味なところでoverflow（これはKickstart my heartを見ていいなあと思ったもの）とか入れてあります。あとはデバッグモードかどうかで吐き出すエラー画面が異なるのが特徴といえば特徴。フラグひとつ変えればそのままプロダクション環境に移行……しちゃ本当はまずいんですが、まあ、そういうこともできるようにということで。
今度は use CGI::Carp qw/fatalsToBroswer/ のかわりに use CGI::Carp::DebugScreen するだけでそれなりの画面が出るはず。設定は

use CGI::Carp::DebugScreen (
  debug => 1,
  engine => 'HTML::Template',
  lines => 5,
  modules => 1,
  environment => 1,
  raw_error => 1,
);

のような格好で。

CGI::Carp::DebugScreen

package CGI::Carp::DebugScreen;
{
  use strict;
  use warnings;
  use Exporter;
  use CGI::Carp qw/fatalsToBrowser/;

  our $VERSION = '0.01';

  BEGIN {
    my $MyDebug = 0;
    CGI::Carp::set_message(
      sub { __PACKAGE__->show(@_) }
    ) unless $MyDebug;
  }

  $Carp::Verbose = 1;   # for stack traces

  my $Debug  = 1;
  my $Engine = 'HTML::Template';
  my $ShowLines = 3;
  my $ShowMod;
  my $ShowEnv;
  my $ShowRawError;
  my $Template;
  my $ErrorTemplate;

  sub import {
    my $pkg = shift;
    my %options = @_;
    while(my ($key, $value) = each %options) {
      next unless defined $value;
      $key = lc $key;
      $Debug     = $value if $key =~ /^d(?:ebug)?$/;
      $Engine    = $value if $key =~ /^e(?:ngine)?$/;
      $ShowLines = $value if $key =~ /^l(?:ines)?$/;
      $ShowMod   = $value if $key =~ /^m(?:od(?:ules)?)?$/;
      $ShowEnv   = $value if $key =~ /^env(?:ironment)?$/;
      $ShowRawError = $value if $key =~ /^raw(?:_error)?$/;
      $ErrorTemplate = $value if $key =~ /^e(?:rror_)?t(?:emplate)?$/;
    }
  }

  sub show_modules       { shift; $ShowMod = shift; }
  sub show_environment   { shift; $ShowEnv = shift; }
  sub show_raw_error     { shift; $ShowRawError = shift; }
  sub debug              { shift; $Debug    = shift; }
  sub set_engine         { shift; $Engine   = shift; }
  sub set_template       { shift; $Template = shift; }
  sub set_error_template { shift; $ErrorTemplate = shift; }

  sub get_contents {
    my ($file, $line_no) = @_;

    my @contents;
    if (open my $fh, '<'.$file) {
      my $ct = 0;
      while(my $line = <$fh>) {
        $ct++;
        next if $ct < $line_no - $ShowLines;
        last if $ct > $line_no + $ShowLines;
        push @contents, {
          no   => $ct,
          line => $line,
          hit  => ($ct == $line_no),
        };
      }
    }
    \@contents;
  }

  sub show {
    my ($pkg, $errstr) = @_;

    my $first_message = '';
    my @traces = grep {
        my $caller = $_->{package};
        (
          $caller eq $INC{'Carp.pm'} or     # ignore Carp;
          $caller eq $INC{'CGI/Carp.pm'}    # ignore CGI::Carp;
        ) ? 0 : 1;
      }
      map {
        my $line = $_;
        my ($message, $caller, $line_no) = 
          $line =~ /^(?:\s*)(.*?)(?: called)? at (\S+) line (\d+)\.?$/;
        $first_message = $message unless $first_message && defined $message;
        my $file = $INC{$caller} || $caller;
        my $contents = get_contents($file,$line_no);
        +{
           message  => $message,
           package  => $caller,
           file     => $caller ne $file ? $file : '',
           contents => $contents,
           line     => $line_no,
         }
      } split(/\n/,$errstr);

    my $error_at = $traces[$#traces]->{package};

    my @modules = ();
    @modules = map {
      my $key = $_;
      (my $package = $key) =~ s|/|::|g;
      +{
        package => $package,
        file    => $INC{$key},
      }
    } sort {$a cmp $b} keys %INC if $ShowMod;

    my @environment = ();
    @environment = map {
      +{
        key   => $_,
        value => $ENV{$_},
      }
    } sort {$a cmp $b} keys %ENV if $ShowEnv;

    my $viewer = __PACKAGE__.'::'.$Engine;

    eval "require $viewer";
    if ($@) {
      print "<html><body><pre>Error: $errstr</pre></body></html>"; exit;
    }

    $viewer->show(
      show_raw_error => $ShowRawError,
      raw_error     => $errstr,
      error_at      => $error_at,
      error_message => $first_message.' at '.$traces[0]->{package}.' line '.$traces[0]->{line},
      traces        => \@traces,
      modules       => \@modules,
      environment   => \@environment,
      debug         => $Debug,
      tmplref       => \$Template,
      error_tmpl    => $ErrorTemplate,
    );
  }
}

1;

CGI::Carp::DebugScreen::HTML::Template

package CGI::Carp::DebugScreen::HTML::Template;
{
  use strict;
  use warnings;
  use HTML::Template;

  our $VERSION = '0.01';

  my $Template =<<'EOT';
<TMPL_IF NAME="debug">
<html> 
<head>
<title>Debug Screen</title>
<style type="text/css">
<!--
  body {
    font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
    Tahoma, Arial, helvetica, sans-serif;
    color: #000;
    background-color: #f90;
    margin: 0px;
    padding: 0px;
  }
  :link, :link:hover, :visited, :visited:hover {
    color: #333;
  }
  div#page {
    position: relative;
    background-color: #fff;
    border: 1px solid #aaa;
    padding: 4px;
    margin: 10px;
    -moz-border-radius: 10px;
  }
  div.navi {
    color: #333;
    padding: 0 4px;
  }
  div.box {
    background-color: #fff;
    border: 3px solid #fc9;
    padding: 8px;
    margin: 4px;
    margin-bottom: 10px;
    -moz-border-radius: 10px;
  }
  h1 {
    margin: 0;
    color: #666;
  }
  h2 {
    margin-top: 0;
    margin-bottom: 10px;
    font-size: medium;
    font-weight: bold;
    text-decoration: underline;
  }
  table.code {
    font-size: .8em;
    line-height: 120%;
    font-family: 'Courier New', Courier, monospace;
    background-color: #fc9;
    color: #333;
    border: 1px dotted #000;
    margin: 8px;
    width: 90%;
    border-collapse: collapse;
  }
  table.code tr.hit {
    font-weight: bold;
    color: #000;
    background-color: #E68200;
  }
  table.code td {
    padding-left: 1em;
    line-height: 130%;
  }
  table.code td.num {
    width: 4em;
    text-align:right
  }
  div.scrollable {
    font-size: .8em;
    overflow: auto;
  }
  pre.raw_error {
    background-color: #fff;
    border: 3px solid #fc9;
    padding: 8px;
    margin: 4px;
    margin-bottom: 10px;
    -moz-border-radius: 10px;
    font-size: .8em;
    line-height: 120%;
    font-family: 'Courier New', Courier, monospace;
    overflow: auto;
  }
  ul#traces, ul#modules {
    margin: 1em 1em;
    padding: 0 1em;
  }
  table#environment {
    margin: 0 1em;
  }
-->
</style>
</head>
<body>
<a name="top"></a>
<div id="page">
<h1><TMPL_VAR NAME="error_at" ESCAPE=HTML></h1>
<TMPL_IF NAME="show_raw_error">
<pre class="raw_error"><TMPL_VAR NAME="raw_error"></pre>
<TMPL_ELSE>
<div class="box">
<TMPL_VAR NAME="error_message">
</div>
</TMPL_IF>
<div class="navi">
[<a href="#top">top</a>]
[<a href="#traces">traces</a>]
<TMPL_IF NAME="modules">[<a href="#modules">modules</a>]</TMPL_IF>
<TMPL_IF NAME="environment">[<a href="#environment">environment</a>]</TMPL_IF>
</div>
<div class="box">
<h2><a name="traces">Stack Traces</a></h2>
<ul id="traces">
<TMPL_LOOP NAME="traces">
<li>
<TMPL_VAR NAME="package" ESCAPE=HTML>
<TMPL_IF NAME="file"> (<TMPL_VAR NAME="file" ESCAPE=HTML>)</TMPL_IF>
LINE : <TMPL_VAR NAME="line" ESCAPE=HTML>
</li>
<table class="code">
<TMPL_LOOP NAME="contents">
<TMPL_IF NAME="hit"><tr class="hit"><TMPL_ELSE><tr></TMPL_IF>
<td class="num"><TMPL_VAR NAME="no" ESCAPE=HTML>:</td>
<td><TMPL_VAR NAME="line" ESCAPE=HTML></td>
</tr>
</TMPL_LOOP>
</table>
</TMPL_LOOP>
</ul>
</div>
<TMPL_IF NAME="modules">
<div class="navi">
[<a href="#top">top</a>]
[<a href="#traces">traces</a>]
<TMPL_IF NAME="modules">[<a href="#modules">modules</a>]</TMPL_IF>
<TMPL_IF NAME="environment">[<a href="#environment">environment</a>]</TMPL_IF>
</div>
<div class="box">
<h2><a name="modules">Included Modules</a></h2>
<ul id="modules">
<TMPL_LOOP NAME="modules">
<li><TMPL_VAR NAME="package" ESCAPE=HTML> (<TMPL_VAR NAME="file" ESCAPE=HTML>)</li>
</TMPL_LOOP>
</ul>
</div>
</TMPL_IF>
<TMPL_IF NAME="environment">
<div class="navi">
[<a href="#top">top</a>]
[<a href="#traces">traces</a>]
<TMPL_IF NAME="modules">[<a href="#modules">modules</a>]</TMPL_IF>
<TMPL_IF NAME="environment">[<a href="#environment">environment</a>]</TMPL_IF>
</div>
<div class="box">
<h2><a name="environment">Environmental Variables</a></h2>
<table id="environment">
<TMPL_LOOP NAME="environment">
<tr>
<td><TMPL_VAR NAME="key" ESCAPE=HTML></td>
<td><div class="scrollable"><TMPL_VAR NAME="value" ESCAPE=HTML></div><//td>
</tr>
</TMPL_LOOP>
</table>
</div>
</TMPL_IF>
</div>
</body>
</html>
<TMPL_ELSE>
<TMPL_IF NAME="error_tmpl">
<TMPL_VAR NAME="error_tmpl">
<TMPL_ELSE>
<html>
<head>
<title>An unexpected error has been detected</title>
<style type="text/css">
<!--
  body {
    font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana,
    Tahoma, Arial, helvetica, sans-serif;
    color: #000;
    background-color: #F90;
    margin: 0px;
    padding: 0px;
  }
  div#page {
    position: relative;
    background-color: #fff;
    border: 1px solid #aaa;
    padding: 4px;
    margin: 10px;
    -moz-border-radius: 10px;
  }
  div.box {
    background-color: #fff;
    border: 3px solid #FFCC99;
    padding: 8px;
    margin: 4px;
    margin-bottom: 10px;
    -moz-border-radius: 10px;
  }
  h1 {
    margin: 0;
    color: #666;
  }
  p {
    margin: 1em;
  }
-->
</style>
</head>
<body>
<div id="page">
<h1>An unexpected error has been detected</h1>
<p>Sorry for inconvenience.</p>
</div>
</body>
</html>
</TMPL_IF>
</TMPL_IF>
EOT

  sub show {
    my ($pkg, %options) = @_;

    my $tref = ${$options{tmplref}} ? $options{tmplref} : \$Template;

    my $tmpl = HTML::Template->new(
      scalarref => $tref,
      die_on_bad_params => 0,
    );

    delete $options{tmplref};

    $tmpl->param(%options);

    print $tmpl->output;
  }
}

1;

もうちょい整理してPOD書いたらアップするつもりです。