File Coverage

blib/lib/Devel/StackTrace/AsHTML.pm
Criterion Covered Total %
statement 75 91 82.4
branch 18 30 60.0
condition 6 10 60.0
subroutine 11 12 91.6
pod 0 3 0.0
total 110 146 75.3


line stmt bran cond sub pod time code
1             package Devel::StackTrace::AsHTML;
2              
3 3     3   1657 use strict;
  3         7  
  3         127  
4 3     3   84 use 5.008_001;
  3         10  
  3         196  
5             our $VERSION = '0.14';
6              
7 3     3   10604 use Data::Dumper;
  3         34979  
  3         245  
8 3     3   7106 use Devel::StackTrace;
  3         13052  
  3         90  
9 3     3   23 use Scalar::Util;
  3         6  
  3         111  
10              
11 3     3   15 no warnings 'qw';
  3         6  
  3         4397  
12             my %enc = qw( & &amp; > &gt; < &lt; " &quot; ' &#39; );
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 629 my $str = shift;
24 38 100       114 $str =~ s/([^\x00-\x21\x23-\x25\x28-\x3b\x3d\x3f-\xff])/$enc{$1} || '&#' . ord($1) . ';' /ge;
  16         101  
25 38         68 utf8::downgrade($str);
26 38         209 $str;
27             }
28              
29             sub Devel::StackTrace::as_html {
30 2     2 0 271 __PACKAGE__->render(@_);
31             }
32              
33             sub render {
34 2     2 0 5 my $class = shift;
35 2         4 my $trace = shift;
36 2         5 my %opt = @_;
37              
38 2         12 my $msg = encode_html($trace->frame(0)->as_string(1));
39 2         11 my $out = qq{<!doctype html><head><title>Error: ${msg}</title>};
40              
41 2   50     18 $opt{style} ||= \<<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       11 if (ref $opt{style}) {
63 2         5 $out .= qq(<style type="text/css">${$opt{style}}</style>);
  2         18  
64             } else {
65 0         0 $out .= qq(<link rel="stylesheet" type="text/css" href=") . encode_html($opt{style}) . q(" />);
66             }
67              
68 2         21 $out .= <<HEAD;
69             <script language="JavaScript" type="text/javascript">
70             function toggleThing(ref, type, hideMsg, showMsg) {
71             var css = document.getElementById(type+'-'+ref).style;
72             css.display = css.display == 'block' ? 'none' : 'block';
73              
74             var hyperlink = document.getElementById('toggle-'+ref);
75             hyperlink.textContent = css.display == 'block' ? hideMsg : showMsg;
76             }
77              
78             function toggleArguments(ref) {
79             toggleThing(ref, 'arguments', 'Hide function arguments', 'Show function arguments');
80             }
81              
82             function toggleLexicals(ref) {
83             toggleThing(ref, 'lexicals', 'Hide lexical variables', 'Show lexical variables');
84             }
85             </script>
86             </head>
87             <body>
88             <h1>Error trace</h1><pre class="message">$msg</pre><ol>
89             HEAD
90              
91 2         5 my $i = 0;
92 2         12 while (my $frame = $trace->next_frame) {
93 4         69 $i++;
94 4         12 my $next_frame = $trace->frame($i); # peek next
95 4 100 66     60 $out .= join(
    50 50        
    50          
96             '',
97             '<li class="frame">',
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(<pre class="context"><code>),
104             _build_context($frame) || '',
105             q(</code></pre>),
106             _build_arguments($i, $next_frame),
107             $frame->can('lexicals') ? _build_lexicals($i, $frame->lexicals) : '',
108             q(</li>),
109             );
110             }
111 2         33 $out .= qq{</ol>};
112 2         5 $out .= "</body></html>";
113              
114 2         28 $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   9 my($id, $frame) = @_;
128 4         11 my $ref = "arg-$id";
129              
130 4 100 66     46 return '' unless $frame && $frame->args;
131              
132 2         21 my @args = $frame->args;
133              
134 2         17 my $html = qq(<p><a class="toggle" id="toggle-$ref" href="javascript:toggleArguments('$ref')">Show function arguments</a></p><table class="arguments" id="arguments-$ref">);
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         6 my $dump = $dumper->($value);
140 2         4 $html .= qq{<tr>};
141 2         6 $html .= qq{<td class="variable">\$_[$idx]</td>};
142 2         6 $html .= qq{<td class="value">} . encode_html($dump) . qq{</td>};
143 2         6 $html .= qq{</tr>};
144             }
145 2         5 $html .= qq(</table>);
146              
147 2         55 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(<p><a class="toggle" id="toggle-$ref" href="javascript:toggleLexicals('$ref')">Show lexical variables</a></p><table class="lexicals" id="lexicals-$ref">);
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{<tr>};
165 0         0 $html .= qq{<td class="variable">} . encode_html($var) . qq{</td>};
166 0         0 $html .= qq{<td class="value">} . encode_html($dump) . qq{</td>};
167 0         0 $html .= qq{</tr>};
168             }
169 0         0 $html .= qq(</table>);
170              
171 0         0 return $html;
172             }
173              
174             sub _build_context {
175 4     4   23 my $frame = shift;
176 4         12 my $file = $frame->filename;
177 4         25 my $linenum = $frame->line;
178 4         16 my $code;
179 4 50       92 if (-f $file) {
180 4         10 my $start = $linenum - 3;
181 4         6 my $end = $linenum + 3;
182 4 50       15 $start = $start < 1 ? 1 : $start;
183 4 50       152 open my $fh, '<', $file
184             or die "cannot open $file:$!";
185 4         6 my $cur_line = 0;
186 4         175 while (my $line = <$fh>) {
187 54         55 ++$cur_line;
188 54 100       100 last if $cur_line > $end;
189 50 100       127 next if $cur_line < $start;
190 28         49 $line =~ s|\t| |g;
191 28 100       73 my @tag = $cur_line == $linenum
192             ? (q{<strong class="match">}, '</strong>')
193             : ('', '');
194 28         56 $code .= sprintf(
195             '%s%5d: %s%s', $tag[0], $cur_line, encode_html($line),
196             $tag[1],
197             );
198             }
199 4         80 close $file;
200             }
201 4         23 return $code;
202             }
203              
204             1;
205             __END__
206              
207             =encoding utf-8
208              
209             =for stopwords
210              
211             =head1 NAME
212              
213             Devel::StackTrace::AsHTML - Displays stack trace in HTML
214              
215             =head1 SYNOPSIS
216              
217             use Devel::StackTrace::AsHTML;
218              
219             my $trace = Devel::StackTrace->new;
220             my $html = $trace->as_html;
221              
222             =head1 DESCRIPTION
223              
224             Devel::StackTrace::AsHTML adds C<as_html> method to L<Devel::StackTrace> which
225             displays the stack trace in beautiful HTML, with code snippet context and
226             function parameters. If you call it on an instance of
227             L<Devel::StackTrace::WithLexicals>, you even get to see the lexical variables
228             of each stack frame.
229              
230             =head1 AUTHOR
231              
232             Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
233              
234             Shawn M Moore
235              
236             HTML generation code is ripped off from L<CGI::ExceptionManager> written by Tokuhiro Matsuno and Kazuho Oku.
237              
238             =head1 LICENSE
239              
240             This library is free software; you can redistribute it and/or modify
241             it under the same terms as Perl itself.
242              
243             =head1 SEE ALSO
244              
245             L<Devel::StackTrace> L<Devel::StackTrace::WithLexicals> L<CGI::ExceptionManager>
246              
247             =cut