blib/lib/Dancer/Error.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 158 | 165 | 95.7 |
branch | 48 | 54 | 88.8 |
condition | 11 | 16 | 68.7 |
subroutine | 32 | 33 | 96.9 |
pod | 11 | 12 | 91.6 |
total | 260 | 280 | 92.8 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package Dancer::Error; | ||||||
2 | our $AUTHORITY = 'cpan:SUKRIA'; | ||||||
3 | #ABSTRACT: class for representing fatal errors | ||||||
4 | $Dancer::Error::VERSION = '1.3514_04'; # TRIAL | ||||||
5 | $Dancer::Error::VERSION = '1.351404'; | ||||||
6 | 169 | 169 | 53788 | use strict; | |||
169 | 294 | ||||||
169 | 4452 | ||||||
7 | 169 | 169 | 793 | use warnings; | |||
169 | 287 | ||||||
169 | 3778 | ||||||
8 | 169 | 169 | 692 | use Carp; | |||
169 | 344 | ||||||
169 | 8486 | ||||||
9 | 169 | 169 | 985 | use Scalar::Util qw(blessed); | |||
169 | 368 | ||||||
169 | 7503 | ||||||
10 | |||||||
11 | 169 | 169 | 986 | use base 'Dancer::Object'; | |||
169 | 339 | ||||||
169 | 17958 | ||||||
12 | |||||||
13 | 169 | 169 | 1354 | use Dancer::Response; | |||
169 | 329 | ||||||
169 | 3833 | ||||||
14 | 169 | 169 | 62743 | use Dancer::Renderer; | |||
169 | 419 | ||||||
169 | 5001 | ||||||
15 | 169 | 169 | 1107 | use Dancer::Config 'setting'; | |||
169 | 335 | ||||||
169 | 6356 | ||||||
16 | 169 | 169 | 844 | use Dancer::Logger; | |||
169 | 399 | ||||||
169 | 2499 | ||||||
17 | 169 | 169 | 713 | use Dancer::Factory::Hook; | |||
169 | 301 | ||||||
169 | 2279 | ||||||
18 | 169 | 169 | 663 | use Dancer::Session; | |||
169 | 311 | ||||||
169 | 3534 | ||||||
19 | 169 | 169 | 804 | use Dancer::FileUtils qw(open_file); | |||
169 | 300 | ||||||
169 | 5697 | ||||||
20 | 169 | 169 | 815 | use Dancer::Engine; | |||
169 | 311 | ||||||
169 | 3381 | ||||||
21 | 169 | 169 | 821 | use Dancer::Exception qw(:all); | |||
169 | 382 | ||||||
169 | 149418 | ||||||
22 | |||||||
23 | Dancer::Factory::Hook->instance->install_hooks( | ||||||
24 | qw/before_error_render after_error_render before_error_init/); | ||||||
25 | |||||||
26 | sub init { | ||||||
27 | 55 | 55 | 1 | 119 | my ($self) = @_; | ||
28 | |||||||
29 | 55 | 195 | Dancer::Factory::Hook->instance->execute_hooks('before_error_init', $self); | ||||
30 | |||||||
31 | 55 | 269 | $self->attributes_defaults( | ||||
32 | title => 'Error ' . $self->code, | ||||||
33 | type => 'runtime error', | ||||||
34 | ); | ||||||
35 | |||||||
36 | 55 | 100 | 174 | $self->has_serializer | |||
37 | and return; | ||||||
38 | |||||||
39 | 48 | 150 | my $html_output = "" . $self->{type} . ""; |
||||
40 | 48 | 150 | $html_output .= $self->backtrace; | ||||
41 | 48 | 191 | $html_output .= $self->environment; | ||||
42 | |||||||
43 | 48 | 391 | $self->{message} = $html_output; | ||||
44 | } | ||||||
45 | |||||||
46 | 55 | 55 | 0 | 179 | sub has_serializer { setting('serializer') } | ||
47 | 162 | 162 | 1 | 793 | sub code { $_[0]->{code} } | ||
48 | 63 | 63 | 1 | 668 | sub title { $_[0]->{title} } | ||
49 | 76 | 76 | 1 | 238 | sub message { $_[0]->{message} } | ||
50 | 96 | 96 | 1 | 357 | sub exception { $_[0]->{exception} } | ||
51 | |||||||
52 | sub backtrace { | ||||||
53 | 48 | 48 | 1 | 99 | my ($self) = @_; | ||
54 | |||||||
55 | 48 | 100 | 172 | $self->{message} ||= ""; | |||
56 | my $message = | ||||||
57 | 48 | 151 | qq|| . _html_encode($self->{message}) . ""; |
||||
58 | |||||||
59 | # the default perl warning/error pattern | ||||||
60 | 48 | 335 | my ($file, $line) = ($message =~ /at (\S+) line (\d+)/); | ||||
61 | |||||||
62 | # the Devel::SimpleTrace pattern | ||||||
63 | 48 | 100 | 66 | 237 | ($file, $line) = ($message =~ /at.*\((\S+):(\d+)\)/) | ||
64 | unless $file and $line; | ||||||
65 | |||||||
66 | # no file/line found, cannot open a file for context | ||||||
67 | 48 | 100 | 66 | 230 | return $message unless ($file and $line); | ||
68 | |||||||
69 | # file and line are located, let's read the source Luke! | ||||||
70 | 36 | 50 | 162 | my $fh = open_file('<', $file) or return $message; | |||
71 | 36 | 1120 | my @lines = <$fh>; | ||||
72 | 36 | 4002 | close $fh; | ||||
73 | |||||||
74 | 36 | 114 | my $backtrace = $message; | ||||
75 | |||||||
76 | 36 | 128 | $backtrace | ||||
77 | .= qq| | . "$file around line $line" . " "; |
||||||
78 | |||||||
79 | 36 | 77 | $backtrace .= qq||; |
||||
80 | |||||||
81 | 36 | 177 | $line--; | ||||
82 | 36 | 50 | 168 | my $start = (($line - 3) >= 0) ? ($line - 3) : 0; | |||
83 | 36 | 50 | 115 | my $stop = (($line + 3) < scalar(@lines)) ? ($line + 3) : scalar(@lines); | |||
84 | |||||||
85 | 36 | 123 | for (my $l = $start; $l <= $stop; $l++) { | ||||
86 | 252 | 406 | chomp $lines[$l]; | ||||
87 | |||||||
88 | 252 | 100 | 387 | if ($l == $line) { | |||
89 | 36 | 100 | $backtrace | ||||
90 | .= qq|| | ||||||
91 | . tabulate($l + 1, $stop + 1) | ||||||
92 | . qq| | | ||||||
93 | . _html_encode($lines[$l]) | ||||||
94 | . "\n"; | ||||||
95 | } | ||||||
96 | else { | ||||||
97 | 216 | 381 | $backtrace | ||||
98 | .= qq|| | ||||||
99 | . tabulate($l + 1, $stop + 1) | ||||||
100 | . " " | ||||||
101 | . _html_encode($lines[$l]) . "\n"; | ||||||
102 | } | ||||||
103 | } | ||||||
104 | 36 | 77 | $backtrace .= ""; | ||||
105 | |||||||
106 | |||||||
107 | 36 | 422 | return $backtrace; | ||||
108 | } | ||||||
109 | |||||||
110 | sub tabulate { | ||||||
111 | 252 | 252 | 1 | 341 | my ($number, $max) = @_; | ||
112 | 252 | 306 | my $len = length($max); | ||||
113 | 252 | 100 | 685 | return $number if length($number) == $len; | |||
114 | 10 | 24 | return " $number"; | ||||
115 | } | ||||||
116 | |||||||
117 | sub dumper { | ||||||
118 | 145 | 145 | 1 | 741 | my $obj = shift; | ||
119 | 145 | 50 | 581 | return "Unavailable without Data::Dumper" | |||
120 | unless Dancer::ModuleLoader->load('Data::Dumper'); | ||||||
121 | |||||||
122 | |||||||
123 | # Take a copy of the data, so we can mask sensitive-looking stuff: | ||||||
124 | 145 | 100 | 333 | my $data = Dancer::ModuleLoader->load('Clone') ? | |||
125 | Clone::clone($obj) | ||||||
126 | : eval Data::Dumper->new([$obj])->Purity(1)->Terse(1)->Deepcopy(1)->Dump; | ||||||
127 | |||||||
128 | 145 | 100 | 884 | $data = {%$data} if blessed($data); | |||
129 | |||||||
130 | 145 | 410 | my $censored = _censor($data); | ||||
131 | |||||||
132 | #use Data::Dumper; | ||||||
133 | 145 | 716 | my $dd = Data::Dumper->new([$data]); | ||||
134 | 145 | 4000 | $dd->Terse(1)->Quotekeys(0)->Indent(1)->Sortkeys(1); | ||||
135 | 145 | 3317 | my $content = $dd->Dump(); | ||||
136 | 145 | 103067 | $content =~ s{(\s*)(\S+)(\s*)=>}{$1$2$3 =>}g; | ||||
137 | 145 | 100 | 493 | if ($censored) { | |||
138 | 48 | 100 | 223 | $content | |||
139 | .= "\n\nNote: Values of $censored sensitive-looking key" | ||||||
140 | . ($censored == 1 ? '' : 's') | ||||||
141 | . " hidden\n"; | ||||||
142 | } | ||||||
143 | 145 | 2729 | return $content; | ||||
144 | } | ||||||
145 | |||||||
146 | # Given a hashref, censor anything that looks sensitive. Returns number of | ||||||
147 | # items which were "censored". | ||||||
148 | sub _censor { | ||||||
149 | 393 | 393 | 2235 | my ( $hash, $recursecount ) = @_; | |||
150 | 393 | 100 | 926 | $recursecount ||= 0; | |||
151 | |||||||
152 | # we're checking recursion ourselves, no need to warn | ||||||
153 | 169 | 169 | 1238 | no warnings 'recursion'; | |||
169 | 421 | ||||||
169 | 170134 | ||||||
154 | |||||||
155 | 393 | 100 | 677 | if ( $recursecount++ > 100 ) { | |||
156 | 1 | 94 | warn "Data exceeding 100 levels, truncating\n"; | ||||
157 | 1 | 7 | return $hash; | ||||
158 | } | ||||||
159 | |||||||
160 | 392 | 50 | 33 | 1187 | if (!$hash || ref $hash ne 'HASH') { | ||
161 | 0 | 0 | carp "_censor given incorrect input: $hash"; | ||||
162 | 0 | 0 | return; | ||||
163 | } | ||||||
164 | |||||||
165 | 392 | 476 | my $censored = 0; | ||||
166 | 392 | 1016 | for my $key (keys %$hash) { | ||||
167 | 3414 | 100 | 9986 | if (ref $hash->{$key} eq 'HASH') { | |||
100 | |||||||
168 | 247 | 571 | $censored += _censor( $hash->{$key}, $recursecount ); | ||||
169 | } | ||||||
170 | elsif ($key =~ /(pass|card?num|pan|cvv2?|ccv|secret|private_key|cookie_key)/i) { | ||||||
171 | 325 | 439 | $hash->{$key} = "Hidden (looks potentially sensitive)"; | ||||
172 | 325 | 370 | $censored++; | ||||
173 | } | ||||||
174 | } | ||||||
175 | |||||||
176 | 392 | 695 | return $censored; | ||||
177 | } | ||||||
178 | |||||||
179 | # Replaces the entities that are illegal in (X)HTML. | ||||||
180 | sub _html_encode { | ||||||
181 | 300 | 300 | 394 | my $value = shift; | |||
182 | |||||||
183 | 300 | 509 | $value =~ s/&/&/g; | ||||
184 | 300 | 388 | $value =~ s/</g; | ||||
185 | 300 | 501 | $value =~ s/>/>/g; | ||||
186 | 300 | 598 | $value =~ s/'/'/g; | ||||
187 | 300 | 508 | $value =~ s/"/"/g; | ||||
188 | |||||||
189 | 300 | 876 | return $value; | ||||
190 | } | ||||||
191 | |||||||
192 | sub render { | ||||||
193 | 53 | 53 | 1 | 557 | my $self = shift; | ||
194 | |||||||
195 | 53 | 148 | my $serializer = setting('serializer'); | ||||
196 | 53 | 100 | 166 | my $ops = { title => $self->title, | |||
197 | message => $self->message, | ||||||
198 | code => $self->code, | ||||||
199 | defined $self->exception ? ( exception => $self->exception ) : (), | ||||||
200 | }; | ||||||
201 | 53 | 344 | Dancer::Factory::Hook->instance->execute_hooks('before_error_render', $self, $ops); | ||||
202 | 53 | 114 | my $response; | ||||
203 | try { | ||||||
204 | 53 | 100 | 53 | 1797 | $response = $serializer ? $self->_render_serialized($ops) : $self->_render_html($ops); | ||
205 | } continuation { | ||||||
206 | 0 | 0 | 0 | my ($continuation) = @_; | |||
207 | # If we have a Route continuation, run the after hook, then | ||||||
208 | # propagate the continuation | ||||||
209 | 0 | 0 | Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response); | ||||
210 | 0 | 0 | $continuation->rethrow(); | ||||
211 | 53 | 497 | }; | ||||
212 | 53 | 1711 | Dancer::Factory::Hook->instance->execute_hooks('after_error_render', $response); | ||||
213 | 53 | 740 | $response; | ||||
214 | } | ||||||
215 | |||||||
216 | sub _render_serialized { | ||||||
217 | 7 | 7 | 12 | my $self = shift; | |||
218 | |||||||
219 | 7 | 100 | 19 | my $message = | |||
220 | !ref $self->message ? {error => $self->message} : $self->message; | ||||||
221 | |||||||
222 | 7 | 100 | 66 | 34 | if (ref $message eq 'HASH' && defined $self->exception) { | ||
223 | 2 | 50 | 5 | if (blessed($self->exception)) { | |||
224 | 0 | 0 | $message->{exception} = ref($self->exception); | ||||
225 | 0 | 0 | $message->{exception} =~ s/^Dancer::Exception:://; | ||||
226 | } else { | ||||||
227 | 2 | 3 | $message->{exception} = $self->exception; | ||||
228 | } | ||||||
229 | } | ||||||
230 | |||||||
231 | 7 | 100 | 22 | if (setting('show_errors')) { | |||
232 | 6 | 18 | Dancer::Response->new( | ||||
233 | status => $self->code, | ||||||
234 | content => Dancer::Serializer->engine->serialize($message), | ||||||
235 | headers => ['Content-Type' => Dancer::Serializer->engine->content_type] | ||||||
236 | ); | ||||||
237 | } | ||||||
238 | |||||||
239 | # if show_errors is disabled, we don't expose the real error message to the | ||||||
240 | # outside world | ||||||
241 | else { | ||||||
242 | 1 | 6 | Dancer::Response->new( | ||||
243 | status => $self->code, | ||||||
244 | content => "An internal error occured", | ||||||
245 | ); | ||||||
246 | } | ||||||
247 | |||||||
248 | } | ||||||
249 | |||||||
250 | sub _render_html { | ||||||
251 | 46 | 46 | 82 | my $self = shift; | |||
252 | 46 | 67 | my $ops = shift; | ||||
253 | |||||||
254 | # I think it is irrelevant to look into show_errors. In the | ||||||
255 | # template the user can hide them if she desires so. | ||||||
256 | 46 | 100 | 128 | if (setting("error_template")) { | |||
257 | 18 | 37 | my $template_name = setting("error_template"); | ||||
258 | 18 | 116 | my $content = Dancer::Engine->engine("template")->apply_renderer($template_name, $ops); | ||||
259 | 18 | 46 | return Dancer::Response->new( | ||||
260 | status => $self->code, | ||||||
261 | headers => ['Content-Type' => 'text/html'], | ||||||
262 | content => $content); | ||||||
263 | } else { | ||||||
264 | 28 | 100 | 72 | return Dancer::Response->new( | |||
265 | status => $self->code, | ||||||
266 | headers => ['Content-Type' => 'text/html'], | ||||||
267 | content => | ||||||
268 | Dancer::Renderer->html_page($self->title, $self->message, 'error') | ||||||
269 | ) if setting('show_errors'); | ||||||
270 | |||||||
271 | 19 | 50 | return Dancer::Renderer->render_error($self->code); | ||||
272 | } | ||||||
273 | } | ||||||
274 | |||||||
275 | sub environment { | ||||||
276 | 48 | 48 | 1 | 94 | my ($self) = @_; | ||
277 | |||||||
278 | 48 | 241 | my $request = Dancer::SharedData->request; | ||||
279 | 48 | 89 | my $r_env = {}; | ||||
280 | 48 | 100 | 206 | $r_env = $request->env if defined $request; | |||
281 | |||||||
282 | 48 | 138 | my $env = | ||||
283 | qq| Environment | |
||||||
284 | . dumper($r_env) | ||||||
285 | . ""; | ||||||
286 | 48 | 463 | my $settings = | ||||
287 | qq| Settings | |
||||||
288 | . dumper(Dancer::Config->settings) | ||||||
289 | . ""; | ||||||
290 | 48 | 202 | my $source = | ||||
291 | qq| Stack | |
||||||
292 | . $self->get_caller | ||||||
293 | . ""; | ||||||
294 | 48 | 105 | my $session = ""; | ||||
295 | |||||||
296 | 48 | 100 | 178 | if (setting('session')) { | |||
297 | 47 | 347 | $session = | ||||
298 | qq[ Session ] |
||||||
299 | . dumper(Dancer::Session->get) | ||||||
300 | . ""; | ||||||
301 | } | ||||||
302 | 48 | 1373 | return "$source $settings $session $env"; | ||||
303 | } | ||||||
304 | |||||||
305 | sub get_caller { | ||||||
306 | 48 | 48 | 1 | 118 | my ($self) = @_; | ||
307 | 48 | 73 | my @stack; | ||||
308 | |||||||
309 | 48 | 74 | my $deepness = 0; | ||||
310 | 48 | 482 | while (my ($package, $file, $line) = caller($deepness++)) { | ||||
311 | 633 | 3478 | push @stack, "$package in $file l. $line"; | ||||
312 | } | ||||||
313 | |||||||
314 | 48 | 408 | return join("\n", reverse(@stack)); | ||||
315 | } | ||||||
316 | |||||||
317 | 1; | ||||||
318 | |||||||
319 | __END__ |