File Coverage

blib/lib/Devel/StackTrace/AsHTMLExtended.pm
Criterion Covered Total %
statement 90 139 64.7
branch 22 48 45.8
condition 4 11 36.3
subroutine 11 13 84.6
pod 0 3 0.0
total 127 214 59.3


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

Error trace

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

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

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

';

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