File Coverage

blib/lib/Devel/StackTrace/AsHTMLExtended.pm
Criterion Covered Total %
statement 89 134 66.4
branch 22 44 50.0
condition 3 9 33.3
subroutine 11 13 84.6
pod 0 3 0.0
total 125 203 61.5


line stmt bran cond sub pod time code
1             package Devel::StackTrace::AsHTMLExtended;
2              
3 2     2   30069 use strict;
  2         4  
  2         58  
4 2     2   29 use 5.008_001;
  2         4  
  2         73  
5             our $VERSION = '0.15';
6              
7 2     2   1222 use Data::Dumper;
  2         14190  
  2         103  
8 2     2   978 use Devel::StackTrace;
  2         4676  
  2         55  
9 2     2   12 use Scalar::Util;
  2         3  
  2         77  
10              
11 2     2   10 no warnings 'qw';
  2         3  
  2         2265  
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 10     10 0 157 my $str = shift;
24 10 100       27 $str =~ s/([^\x00-\x21\x23-\x25\x28-\x3b\x3d\x3f-\xff])/$enc{$1} || '&#' . ord($1) . ';' /ge;
  7         31  
25 10         13 utf8::downgrade($str);
26 10         41 $str;
27             }
28              
29             sub Devel::StackTrace::as_html_extended {
30 1     1 0 85 __PACKAGE__->render(@_);
31             }
32              
33             sub render {
34 1     1 0 2 my $class = shift;
35 1         2 my $trace = shift;
36 1         2 my %opt = @_;
37              
38 1   33     6 my $msg = $opt{msg} // encode_html($trace->frame(0)->as_string(1));
39              
40 1         2 my $out;
41              
42 1 50       4 if (!$opt{inline}) {
43 1         3 $out = qq{
44             Error: ${msg}};
45 1         2 $out .= '
46            
50            
51            
52            
53            
54             ';
55             }
56              
57 1 50       2 if (ref $opt{style}) {
58 0         0 $out .= qq();
  0         0  
59             } else {
60 1         3 $out .= qq();
61             }
62              
63 1 50       3 if (!$opt{inline}) {
64 1         3 $out .= qq(

Error trace

$msg
);
65             }
66              
67 1         1 my $i = 0;
68 1         4 while (my $frame = $trace->next_frame) {
69 1         22 $i++;
70 1         3 my $next_frame = $trace->frame($i); # peek next
71              
72 1         7 my $file_link;
73 1 50       3 if ($frame->filename) {
74              
75 1 50       10 if ($opt{source_link}) {
76 0         0 my $link_url = $opt{source_link}->($frame->filename, $frame->line);
77 0         0 $file_link = q() . encode_html($frame->filename) . q();
78             } else {
79 1         3 $file_link = encode_html($frame->filename);
80             }
81             }
82            
83 1         3 $out .= '
';
84 1 50 33     4 if ($next_frame && $next_frame->subroutine) {
85 0         0 $out .= "

" . encode_html($next_frame->subroutine) . "

";
86 0         0 $out .= '
at ';
87 0 0       0 $out .= $frame->filename ? $file_link : '';
88 0         0 $out .= ' line ';
89 0         0 $out .= $frame->line;
90 0         0 $out .= '';
91             } else {
92 1         1 $out .= '

';

93 1 50       3 $out .= $frame->filename ? $file_link : '';
94 1         5 $out .= ' line ';
95 1         2 $out .= $frame->line;
96 1         4 $out .= '';
97             }
98 1         2 $out .= '';
99              
100 1         1 $out .= '
';
101 1         1 $out .= '
';
102 1         16 $out .= _build_context($frame);
103 1         2 $out .= '';
104              
105 1 50       3 if (!$opt{inline}) {
106 1         3 $out .= qq{
};
107 1         3 $out .= _build_arguments($i, $next_frame);
108 1 50       9 if ($frame->can('lexicals')) {
109 0         0 $out .= _build_lexicals($i, $frame->lexicals)
110             }
111 1         2 $out .= qq{};
112             }
113              
114 1         3 $out .= '';
115             }
116              
117 1 50       14 if (!$opt{inline}) {
118 1         2 $out .= '';
132              
133 1         2 $out .= "
Generated by Devel::StackTrace::AsHTMLExtended $VERSION
";
134 1         2 $out .= '';
135             }
136              
137 1         3 $out;
138             }
139              
140             my $dumper = sub {
141             my $value = shift;
142             $value = $$value if ref $value eq 'SCALAR' or ref $value eq 'REF';
143             my $d = Data::Dumper->new([ $value ]);
144             $d->Indent(1)->Terse(1)->Deparse(1);
145             chomp(my $dump = $d->Dump);
146             $dump;
147             };
148              
149             sub _build_accordian_panel {
150 0     0   0 my ($id, $sub_id, $title, $contents) = @_;
151 0         0 my $ref = "p-$id-$sub_id";
152              
153 0         0 my $html = '
';
154 0         0 $html .= qq{};
155 0         0 $html .= $title;
156 0         0 $html .= '';
157 0         0 $html .= qq{
$contents
};
158 0         0 $html .= '';
159 0         0 return $html;
160             }
161              
162             sub _build_arguments {
163 1     1   2 my($id, $frame) = @_;
164 1         2 my $ref = "arg-$id";
165              
166 1 50 33     5 return '' unless $frame && $frame->args;
167              
168 0         0 my @args = $frame->args;
169              
170 0         0 my $html = qq(); }; }; }; };
ArgumentValue
171            
172             # Don't use while each since Dumper confuses that
173 0         0 for my $idx (0 .. @args - 1) {
174 0         0 my $value = $args[$idx];
175 0         0 my $dump = $dumper->($value);
176 0         0 $html .= qq{
177 0         0 $html .= qq{\$_[$idx]
178 0         0 $html .= qq{
} . encode_html($dump) . qq{
179 0         0 $html .= qq{
180             }
181 0         0 $html .= qq(
);
182              
183 0         0 return _build_accordian_panel($id, "args", "View Arguments", $html);
184             }
185              
186             sub _build_lexicals {
187 0     0   0 my($id, $lexicals) = @_;
188              
189 0 0       0 return '' unless keys %$lexicals;
190              
191 0         0 my $html = qq(); }; }; }; };
VariableValue
192             # Don't use while each since Dumper confuses that
193 0         0 for my $var (sort keys %$lexicals) {
194 0         0 my $value = $lexicals->{$var};
195 0         0 my $dump = $dumper->($value);
196 0 0       0 $dump =~ s/^\{(.*)\}$/($1)/s if $var =~ /^\%/;
197 0 0       0 $dump =~ s/^\[(.*)\]$/($1)/s if $var =~ /^\@/;
198 0         0 $html .= q{
199 0         0 $html .= q{} . encode_html($var) . q{
200 0         0 $html .= q{
} . encode_html($dump) . q{
201 0         0 $html .= q{
202             }
203 0         0 $html .= qq(
);
204              
205 0         0 return _build_accordian_panel($id, "lex", "View Lexicals", $html);
206             }
207              
208             sub _build_context {
209 1     1   2 my $frame = shift;
210 1         2 my $file = $frame->filename;
211 1         5 my $linenum = $frame->line;
212 1         3 my $code;
213 1 50       40 if (-f $file) {
214 1         2 my $start = $linenum - 3;
215 1         3 my $end = $linenum + 3;
216 1 50       4 $start = $start < 1 ? 1 : $start;
217 1 50       34 open my $fh, '<', $file
218             or die "cannot open $file:$!";
219 1         2 my $cur_line = 0;
220 1         19 while (my $line = <$fh>) {
221 9         5 ++$cur_line;
222 9 100       14 last if $cur_line > $end;
223 8 100       13 next if $cur_line < $start;
224 7         10 $line =~ s|\t| |g;
225 7 100       12 my @tag = $cur_line == $linenum
226             ? (q{}, '')
227             : ('', '');
228 7         14 $code .= sprintf(
229             '%s%5d: %s%s', $tag[0], $cur_line, encode_html($line),
230             $tag[1],
231             );
232             }
233 1         13 close $file;
234             }
235 1         3 return $code;
236             }
237              
238             1;
239             __END__