File Coverage

blib/lib/Devel/StackTrace/AsHTML.pm
Criterion Covered Total %
statement 74 90 82.2
branch 18 30 60.0
condition 6 10 60.0
subroutine 11 12 91.6
pod 0 3 0.0
total 109 145 75.1


line stmt bran cond sub pod time code
1             package Devel::StackTrace::AsHTML;
2              
3 3     3   39326 use strict;
  3         3  
  3         64  
4 3     3   46 use 5.008_001;
  3         7  
5             our $VERSION = '0.15';
6              
7 3     3   1709 use Data::Dumper;
  3         18729  
  3         141  
8 3     3   1186 use Devel::StackTrace;
  3         6610  
  3         59  
9 3     3   13 use Scalar::Util;
  3         3  
  3         95  
10              
11 3     3   14 no warnings 'qw';
  3         3  
  3         2494  
12             my %enc = qw( & & > > < < " " ' ' );
13              
14             # NOTE: because we don't know which encoding $str is in, or even if
15             # $str is a wide character (decoded strings), we just leave the low
16             # bits, including latin-1 range and encode everything higher as HTML
17             # entities. I know this is NOT always correct, but should mostly work
18             # in case $str is encoded in utf-8 bytes or wide chars. This is a
19             # necessary workaround since we're rendering someone else's code which
20             # we can't enforce string encodings.
21              
22             sub encode_html {
23 38     38 0 387 my $str = shift;
24 38 100       68 $str =~ s/([^\x00-\x21\x23-\x25\x28-\x3b\x3d\x3f-\xff])/$enc{$1} || '&#' . ord($1) . ';' /ge;
  16         66  
25 38         40 utf8::downgrade($str);
26 38         167 $str;
27             }
28              
29             sub Devel::StackTrace::as_html {
30 2     2 0 178 __PACKAGE__->render(@_);
31             }
32              
33             sub render {
34 2     2 0 3 my $class = shift;
35 2         3 my $trace = shift;
36 2         3 my %opt = @_;
37              
38 2         7 my $msg = encode_html($trace->frame(0)->as_string(1));
39 2         9 my $out = qq{Error: ${msg}};
40              
41 2   50     14 $opt{style} ||= \<
42             a.toggle { color: #444 }
43             body { margin: 0; padding: 0; background: #fff; color: #000; }
44             h1 { margin: 0 0 .5em; padding: .25em .5em .1em 1.5em; border-bottom: thick solid #002; background: #444; color: #eee; font-size: x-large; }
45             pre.message { margin: .5em 1em; }
46             li.frame { font-size: small; margin-top: 3em }
47             li.frame:nth-child(1) { margin-top: 0 }
48             pre.context { border: 1px solid #aaa; padding: 0.2em 0; background: #fff; color: #444; font-size: medium; }
49             pre .match { color: #000;background-color: #f99; font-weight: bold }
50             pre.vardump { margin:0 }
51             pre code strong { color: #000; background: #f88; }
52              
53             table.lexicals, table.arguments { border-collapse: collapse }
54             table.lexicals td, table.arguments td { border: 1px solid #000; margin: 0; padding: .3em }
55             table.lexicals tr:nth-child(2n) { background: #DDDDFF }
56             table.arguments tr:nth-child(2n) { background: #DDFFDD }
57             .lexicals, .arguments { display: none }
58             .variable, .value { font-family: monospace; white-space: pre }
59             td.variable { vertical-align: top }
60             STYLE
61              
62 2 50       7 if (ref $opt{style}) {
63 2         3 $out .= qq();
  2         12  
64             } else {
65 0         0 $out .= qq();
66             }
67              
68 2         15 $out .= <
69            
86            
87            
88            

Error trace

$msg
89             HEAD
90              
91 2         5 my $i = 0;
92 2         9 while (my $frame = $trace->next_frame) {
93 4         56 $i++;
94 4         9 my $next_frame = $trace->frame($i); # peek next
95 4 100 66     44 $out .= join(
    50 50        
    50          
96             '',
97             '
  • ',
    • 98             ($next_frame && $next_frame->subroutine) ? encode_html("in " . $next_frame->subroutine) : '',
    99             ' at ',
    100             $frame->filename ? encode_html($frame->filename) : '',
    101             ' line ',
    102             $frame->line,
    103             q(
    ),
    104             _build_context($frame) || '',
    105             q(),
    106             _build_arguments($i, $next_frame),
    107             $frame->can('lexicals') ? _build_lexicals($i, $frame->lexicals) : '',
    108             q(),
    109             );
    110             }
    111 2         24 $out .= qq{};
    112 2         4 $out .= "";
    113              
    114 2         18 $out;
    115             }
    116              
    117             my $dumper = sub {
    118             my $value = shift;
    119             $value = $$value if ref $value eq 'SCALAR' or ref $value eq 'REF';
    120             my $d = Data::Dumper->new([ $value ]);
    121             $d->Indent(1)->Terse(1)->Deparse(1);
    122             chomp(my $dump = $d->Dump);
    123             $dump;
    124             };
    125              
    126             sub _build_arguments {
    127 4     4   7 my($id, $frame) = @_;
    128 4         7 my $ref = "arg-$id";
    129              
    130 4 100 66     33 return '' unless $frame && $frame->args;
    131              
    132 2         18 my @args = $frame->args;
    133              
    134 2         13 my $html = qq(

    Show function arguments

    ); }; }; }; };
    135              
    136             # Don't use while each since Dumper confuses that
    137 2         6 for my $idx (0 .. @args - 1) {
    138 2         4 my $value = $args[$idx];
    139 2         4 my $dump = $dumper->($value);
    140 2         3 $html .= qq{
    141 2         4 $html .= qq{\$_[$idx]
    142 2         2 $html .= qq{} . encode_html($dump) . qq{
    143 2         4 $html .= qq{
    144             }
    145 2         2 $html .= qq(
    );
    146              
    147 2         19 return $html;
    148             }
    149              
    150             sub _build_lexicals {
    151 0     0   0 my($id, $lexicals) = @_;
    152 0         0 my $ref = "lex-$id";
    153              
    154 0 0       0 return '' unless keys %$lexicals;
    155              
    156 0         0 my $html = qq(

    Show lexical variables

    ); }; }; }; };
    157              
    158             # Don't use while each since Dumper confuses that
    159 0         0 for my $var (sort keys %$lexicals) {
    160 0         0 my $value = $lexicals->{$var};
    161 0         0 my $dump = $dumper->($value);
    162 0 0       0 $dump =~ s/^\{(.*)\}$/($1)/s if $var =~ /^\%/;
    163 0 0       0 $dump =~ s/^\[(.*)\]$/($1)/s if $var =~ /^\@/;
    164 0         0 $html .= qq{
    165 0         0 $html .= qq{} . encode_html($var) . qq{
    166 0         0 $html .= qq{} . encode_html($dump) . qq{
    167 0         0 $html .= qq{
    168             }
    169 0         0 $html .= qq(
    );
    170              
    171 0         0 return $html;
    172             }
    173              
    174             sub _build_context {
    175 4     4   12 my $frame = shift;
    176 4         10 my $file = $frame->filename;
    177 4         15 my $linenum = $frame->line;
    178 4         9 my $code;
    179 4 50       53 if (-f $file) {
    180 4         5 my $start = $linenum - 3;
    181 4         6 my $end = $linenum + 3;
    182 4 50       6 $start = $start < 1 ? 1 : $start;
    183 4 50       83 open my $fh, '<', $file
    184             or die "cannot open $file:$!";
    185 4         6 my $cur_line = 0;
    186 4         48 while (my $line = <$fh>) {
    187 54         33 ++$cur_line;
    188 54 100       62 last if $cur_line > $end;
    189 50 100       71 next if $cur_line < $start;
    190 28         26 $line =~ s|\t| |g;
    191 28 100       58 my @tag = $cur_line == $linenum
    192             ? (q{}, '')
    193             : ('', '');
    194 28         43 $code .= sprintf(
    195             '%s%5d: %s%s', $tag[0], $cur_line, encode_html($line),
    196             $tag[1],
    197             );
    198             }
    199 4         97 close $file;
    200             }
    201 4         21 return $code;
    202             }
    203              
    204             1;
    205             __END__