Filename | /usr/local/share/perl/5.18.2/Devel/StackTrace/AsHTML.pm |
Statements | Executed 16 statements in 1.02ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 3.52ms | 3.85ms | BEGIN@7 | Devel::StackTrace::AsHTML::
1 | 1 | 1 | 13µs | 26µs | BEGIN@3 | Devel::StackTrace::AsHTML::
1 | 1 | 1 | 12µs | 12µs | BEGIN@4 | Devel::StackTrace::AsHTML::
1 | 1 | 1 | 8µs | 18µs | BEGIN@11 | Devel::StackTrace::AsHTML::
1 | 1 | 1 | 6µs | 21µs | BEGIN@9 | Devel::StackTrace::AsHTML::
1 | 1 | 1 | 5µs | 5µs | BEGIN@8 | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | __ANON__[:124] | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | _build_arguments | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | _build_context | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | _build_lexicals | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | encode_html | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | render | Devel::StackTrace::AsHTML::
0 | 0 | 0 | 0s | 0s | as_html | Devel::StackTrace::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Devel::StackTrace::AsHTML; | ||||
2 | |||||
3 | 2 | 24µs | 2 | 39µs | # spent 26µs (13+13) within Devel::StackTrace::AsHTML::BEGIN@3 which was called:
# once (13µs+13µs) by Plack::Middleware::StackTrace::BEGIN@6 at line 3 # spent 26µs making 1 call to Devel::StackTrace::AsHTML::BEGIN@3
# spent 13µs making 1 call to strict::import |
4 | 2 | 47µs | 1 | 12µs | # spent 12µs within Devel::StackTrace::AsHTML::BEGIN@4 which was called:
# once (12µs+0s) by Plack::Middleware::StackTrace::BEGIN@6 at line 4 # spent 12µs making 1 call to Devel::StackTrace::AsHTML::BEGIN@4 |
5 | 1 | 400ns | our $VERSION = '0.14'; | ||
6 | |||||
7 | 2 | 130µs | 2 | 3.89ms | # spent 3.85ms (3.52+332µs) within Devel::StackTrace::AsHTML::BEGIN@7 which was called:
# once (3.52ms+332µs) by Plack::Middleware::StackTrace::BEGIN@6 at line 7 # spent 3.85ms making 1 call to Devel::StackTrace::AsHTML::BEGIN@7
# spent 40µs making 1 call to Exporter::import |
8 | 2 | 21µs | 1 | 5µs | # spent 5µs within Devel::StackTrace::AsHTML::BEGIN@8 which was called:
# once (5µs+0s) by Plack::Middleware::StackTrace::BEGIN@6 at line 8 # spent 5µs making 1 call to Devel::StackTrace::AsHTML::BEGIN@8 |
9 | 2 | 22µs | 2 | 36µs | # spent 21µs (6+15) within Devel::StackTrace::AsHTML::BEGIN@9 which was called:
# once (6µs+15µs) by Plack::Middleware::StackTrace::BEGIN@6 at line 9 # spent 21µs making 1 call to Devel::StackTrace::AsHTML::BEGIN@9
# spent 15µs making 1 call to Exporter::import |
10 | |||||
11 | 2 | 765µs | 2 | 29µs | # spent 18µs (8+11) within Devel::StackTrace::AsHTML::BEGIN@11 which was called:
# once (8µs+11µs) by Plack::Middleware::StackTrace::BEGIN@6 at line 11 # spent 18µs making 1 call to Devel::StackTrace::AsHTML::BEGIN@11
# spent 11µs making 1 call to warnings::unimport |
12 | 1 | 4µs | 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 | my $str = shift; | ||||
24 | $str =~ s/([^\x00-\x21\x23-\x25\x28-\x3b\x3d\x3f-\xff])/$enc{$1} || '&#' . ord($1) . ';' /ge; | ||||
25 | utf8::downgrade($str); | ||||
26 | $str; | ||||
27 | } | ||||
28 | |||||
29 | sub Devel::StackTrace::as_html { | ||||
30 | __PACKAGE__->render(@_); | ||||
31 | } | ||||
32 | |||||
33 | sub render { | ||||
34 | my $class = shift; | ||||
35 | my $trace = shift; | ||||
36 | my %opt = @_; | ||||
37 | |||||
38 | my $msg = encode_html($trace->frame(0)->as_string(1)); | ||||
39 | my $out = qq{<!doctype html><head><title>Error: ${msg}</title>}; | ||||
40 | |||||
41 | $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 | if (ref $opt{style}) { | ||||
63 | $out .= qq(<style type="text/css">${$opt{style}}</style>); | ||||
64 | } else { | ||||
65 | $out .= qq(<link rel="stylesheet" type="text/css" href=") . encode_html($opt{style}) . q(" />); | ||||
66 | } | ||||
67 | |||||
68 | $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 | my $i = 0; | ||||
92 | while (my $frame = $trace->next_frame) { | ||||
93 | $i++; | ||||
94 | my $next_frame = $trace->frame($i); # peek next | ||||
95 | $out .= join( | ||||
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 | $out .= qq{</ol>}; | ||||
112 | $out .= "</body></html>"; | ||||
113 | |||||
114 | $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 | 1 | 2µs | }; | ||
125 | |||||
126 | sub _build_arguments { | ||||
127 | my($id, $frame) = @_; | ||||
128 | my $ref = "arg-$id"; | ||||
129 | |||||
130 | return '' unless $frame && $frame->args; | ||||
131 | |||||
132 | my @args = $frame->args; | ||||
133 | |||||
134 | 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 | for my $idx (0 .. @args - 1) { | ||||
138 | my $value = $args[$idx]; | ||||
139 | my $dump = $dumper->($value); | ||||
140 | $html .= qq{<tr>}; | ||||
141 | $html .= qq{<td class="variable">\$_[$idx]</td>}; | ||||
142 | $html .= qq{<td class="value">} . encode_html($dump) . qq{</td>}; | ||||
143 | $html .= qq{</tr>}; | ||||
144 | } | ||||
145 | $html .= qq(</table>); | ||||
146 | |||||
147 | return $html; | ||||
148 | } | ||||
149 | |||||
150 | sub _build_lexicals { | ||||
151 | my($id, $lexicals) = @_; | ||||
152 | my $ref = "lex-$id"; | ||||
153 | |||||
154 | return '' unless keys %$lexicals; | ||||
155 | |||||
156 | 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 | for my $var (sort keys %$lexicals) { | ||||
160 | my $value = $lexicals->{$var}; | ||||
161 | my $dump = $dumper->($value); | ||||
162 | $dump =~ s/^\{(.*)\}$/($1)/s if $var =~ /^\%/; | ||||
163 | $dump =~ s/^\[(.*)\]$/($1)/s if $var =~ /^\@/; | ||||
164 | $html .= qq{<tr>}; | ||||
165 | $html .= qq{<td class="variable">} . encode_html($var) . qq{</td>}; | ||||
166 | $html .= qq{<td class="value">} . encode_html($dump) . qq{</td>}; | ||||
167 | $html .= qq{</tr>}; | ||||
168 | } | ||||
169 | $html .= qq(</table>); | ||||
170 | |||||
171 | return $html; | ||||
172 | } | ||||
173 | |||||
174 | sub _build_context { | ||||
175 | my $frame = shift; | ||||
176 | my $file = $frame->filename; | ||||
177 | my $linenum = $frame->line; | ||||
178 | my $code; | ||||
179 | if (-f $file) { | ||||
180 | my $start = $linenum - 3; | ||||
181 | my $end = $linenum + 3; | ||||
182 | $start = $start < 1 ? 1 : $start; | ||||
183 | open my $fh, '<', $file | ||||
184 | or die "cannot open $file:$!"; | ||||
185 | my $cur_line = 0; | ||||
186 | while (my $line = <$fh>) { | ||||
187 | ++$cur_line; | ||||
188 | last if $cur_line > $end; | ||||
189 | next if $cur_line < $start; | ||||
190 | $line =~ s|\t| |g; | ||||
191 | my @tag = $cur_line == $linenum | ||||
192 | ? (q{<strong class="match">}, '</strong>') | ||||
193 | : ('', ''); | ||||
194 | $code .= sprintf( | ||||
195 | '%s%5d: %s%s', $tag[0], $cur_line, encode_html($line), | ||||
196 | $tag[1], | ||||
197 | ); | ||||
198 | } | ||||
199 | close $file; | ||||
200 | } | ||||
201 | return $code; | ||||
202 | } | ||||
203 | |||||
204 | 1 | 4µs | 1; | ||
205 | __END__ |