File Coverage

blib/lib/Plack/Middleware/InteractiveDebugger/HTML.pm

Criterion	Covered	Total	%
statement	15	56	26.7
branch	0	12	0.0
condition	0	2	0.0
subroutine	5	13	38.4
pod	0	8	0.0
total	20	91	21.9

package Plack::Middleware::InteractiveDebugger::HTML;
use strict;
use warnings;

use parent qw(Exporter);
our @EXPORT = qw( render_full render_source encode_html );

use Scalar::Util qw(refaddr);

my $header = <

  "http://www.w3.org/TR/html4/loose.dtd">


    %(title) // Plack Interactive Debugger



     </td>
</tr>

<tr>
<td  class="h" >
<a name="20">20</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">       var APP_BASE = '%(script_name)', </td>
</tr>

<tr>
<td  class="h" >
<a name="21">21</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">           TRACEBACK = %(traceback_id), </td>
</tr>

<tr>
<td  class="h" >
<a name="22">22</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">           CONSOLE_MODE = %(console), </td>
</tr>

<tr>
<td  class="h" >
<a name="23">23</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">           EVALEX = %(evalex); </td>
</tr>

<tr>
<td  class="h" >
<a name="24">24</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">



EOF

my $footer = <

        Brought to you by DON'T PANIC, your
        friendly Plack powered stacktrace interpreter, inspired by Werkzeug.




EOF

my $page_html = $header . <
%(exception_type)

  %(exception)

StackTrace (most recent call first)
%(summary)


      This is the Copy/Paste friendly version of the stacktrace.

    %(plaintext)



  The debugger caught an exception in your PSGI application.  You can now
  look at the stacktrace which led to the error.
  If you enable JavaScript you can also use additional features such as code
  execution and much more.

EOF

my $console_html = $header . <
Interactive Console

In this console you can execute Perl expressions in the context of the
application.

The Console requires JavaScript.
EOF

my $summary_html = <

  StackTrace (most recent call first)
  %(frames)

EOF

my $frame_html = <

  File "%(filename)",
      line %(lineno),
      in %(function_name)
  %(current_line)

EOF

my $source_table_html = '%(source)';

my $source_line_html = <




EOF

no warnings 'qw';
my %enc = qw( & & > > < < " " ' ' );

sub encode_html {
    my $str = shift;
    $str =~ s/([^\x00-\x21\x23-\x25\x28-\x3b\x3d\x3f-\xff])/$enc{$1} || '&#' . ord($1) . ';' /ge;
    utf8::downgrade($str);
    $str;
}

sub render {
    my($html, $vars) = @_;
    $html =~ s/%\((.*?)\)/$vars->{$1}/g;
    $html;
}

sub current_line {
    my $frame = shift;

    open my $fh, "<", $frame->filename or return '';
    my @lines = <$fh>;

    my $line = $lines[$frame->line-1];
    $line =~ s/^\s+//;
    $line;
}

sub render_frame {
    my($trace, $idx) = @_;

    my $frame = $trace->frame($idx);

    render $frame_html, {
        id            => refaddr($trace) . "-" . $idx,
        filename      => encode_html($frame->filename),
        lineno        => $frame->line,
        function_name => $frame->subroutine ? encode_html($frame->subroutine) : '',
        current_line  => current_line($frame),
    };
}

sub render_line {
    my($frame, $line, $lineno) = @_;

    my @classes = ('line');
    push @classes, 'current' if $frame->line == $lineno;

    render $source_line_html, {
        classes => join(" ", @classes),
        lineno  => $lineno,
        code    => encode_html($line),
    };
}

sub render_source {
    my $frame = shift;

    my $source;

    open my $fh, "<", $frame->filename or return '';
    my @lines = <$fh>;

    my $lineno = 1;
    for my $line (@lines) {
        $source .= render_line $frame, $line, $lineno++;
        $source .= "\n";
    }

    render $source_table_html, { source => $source };
}

sub render_summary {
    my $trace = shift;

    my @classes = ('traceback');
    unless ($trace->frames) {
        push @classes, 'noframe-traceback';
    }

    my $out;
    for my $idx (0..$trace->frame_count-1) {
        $out .= '' . render_frame($trace, $idx);
    }

    render $summary_html, {
        classes => join(" ", @classes),
        frames  => $out,
    };
}

sub render_full {
    my($env, $trace) = @_;
    my $msg = encode_html($trace->frame(0)->as_string(1));
    render $page_html, {
        script_name => $env->{SCRIPT_NAME},
        evalex      => 'true',
        console     => 'false',
        title       => $msg,
        exception   => $msg,
        exception_type => ref(($trace->frame(0)->args)[0]) || "Error",
        summary     => render_summary($trace),
        plaintext   => $trace->as_string,
        traceback_id => refaddr($trace),
    };
}

1;