Filename | /Users/ap13/perl5/lib/perl5/Error.pm |
Statements | Executed 39 statements in 2.74ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 22µs | 277µs | import | Error::
1 | 1 | 1 | 15µs | 15µs | BEGIN@16 | Error::
1 | 1 | 1 | 13µs | 28µs | BEGIN@14 | Error::
1 | 1 | 1 | 12µs | 63µs | BEGIN@20 | Error::
1 | 1 | 1 | 9µs | 37µs | BEGIN@15 | Error::
1 | 1 | 1 | 8µs | 28µs | BEGIN@260 | Error::Simple::
1 | 1 | 1 | 7µs | 47µs | BEGIN@299 | Error::subs::
1 | 1 | 1 | 5µs | 5µs | BEGIN@298 | Error::subs::
1 | 1 | 1 | 4µs | 4µs | BEGIN@46 | Error::
0 | 0 | 0 | 0s | 0s | new | Error::Simple::
0 | 0 | 0 | 0s | 0s | stringify | Error::Simple::
0 | 0 | 0 | 0s | 0s | DEATH | Error::WarnDie::
0 | 0 | 0 | 0s | 0s | TAXES | Error::WarnDie::
0 | 0 | 0 | 0s | 0s | gen_callstack | Error::WarnDie::
0 | 0 | 0 | 0s | 0s | import | Error::WarnDie::
0 | 0 | 0 | 0s | 0s | __ANON__[:23] | Error::
0 | 0 | 0 | 0s | 0s | _throw_Error_Simple | Error::
0 | 0 | 0 | 0s | 0s | associate | Error::
0 | 0 | 0 | 0s | 0s | catch | Error::
0 | 0 | 0 | 0s | 0s | file | Error::
0 | 0 | 0 | 0s | 0s | flush | Error::
0 | 0 | 0 | 0s | 0s | line | Error::
0 | 0 | 0 | 0s | 0s | new | Error::
0 | 0 | 0 | 0s | 0s | object | Error::
0 | 0 | 0 | 0s | 0s | prior | Error::
0 | 0 | 0 | 0s | 0s | record | Error::
0 | 0 | 0 | 0s | 0s | stacktrace | Error::
0 | 0 | 0 | 0s | 0s | stringify | Error::
0 | 0 | 0 | 0s | 0s | __ANON__[:495] | Error::subs::
0 | 0 | 0 | 0s | 0s | except | Error::subs::
0 | 0 | 0 | 0s | 0s | finally | Error::subs::
0 | 0 | 0 | 0s | 0s | otherwise | Error::subs::
0 | 0 | 0 | 0s | 0s | run_clauses | Error::subs::
0 | 0 | 0 | 0s | 0s | try | Error::subs::
0 | 0 | 0 | 0s | 0s | with | Error::subs::
0 | 0 | 0 | 0s | 0s | text | Error::
0 | 0 | 0 | 0s | 0s | throw | Error::
0 | 0 | 0 | 0s | 0s | value | Error::
0 | 0 | 0 | 0s | 0s | with | Error::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | # Error.pm | ||||
2 | # | ||||
3 | # Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. All rights reserved. | ||||
4 | # This program is free software; you can redistribute it and/or | ||||
5 | # modify it under the same terms as Perl itself. | ||||
6 | # | ||||
7 | # Based on my original Error.pm, and Exceptions.pm by Peter Seibel | ||||
8 | # <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>. | ||||
9 | # | ||||
10 | # but modified ***significantly*** | ||||
11 | |||||
12 | package Error; | ||||
13 | |||||
14 | 2 | 27µs | 2 | 42µs | # spent 28µs (13+14) within Error::BEGIN@14 which was called:
# once (13µs+14µs) by Bio::Root::Root::BEGIN@146 at line 14 # spent 28µs making 1 call to Error::BEGIN@14
# spent 14µs making 1 call to strict::import |
15 | 2 | 25µs | 2 | 65µs | # spent 37µs (9+28) within Error::BEGIN@15 which was called:
# once (9µs+28µs) by Bio::Root::Root::BEGIN@146 at line 15 # spent 37µs making 1 call to Error::BEGIN@15
# spent 28µs making 1 call to vars::import |
16 | 2 | 88µs | 1 | 15µs | # spent 15µs within Error::BEGIN@16 which was called:
# once (15µs+0s) by Bio::Root::Root::BEGIN@146 at line 16 # spent 15µs making 1 call to Error::BEGIN@16 |
17 | |||||
18 | 1 | 1µs | $VERSION = "0.17021"; | ||
19 | |||||
20 | # spent 63µs (12+51) within Error::BEGIN@20 which was called:
# once (12µs+51µs) by Bio::Root::Root::BEGIN@146 at line 25 | ||||
21 | '""' => 'stringify', | ||||
22 | '0+' => 'value', | ||||
23 | 'bool' => sub { return 1; }, | ||||
24 | 2 | 13µs | 'fallback' => 1 | ||
25 | 1 | 90µs | 2 | 114µs | ); # spent 63µs making 1 call to Error::BEGIN@20
# spent 51µs making 1 call to overload::import |
26 | |||||
27 | 1 | 300ns | $Error::Depth = 0; # Depth to pass to caller() | ||
28 | 1 | 200ns | $Error::Debug = 0; # Generate verbose stack traces | ||
29 | 1 | 1µs | @Error::STACK = (); # Clause stack for try | ||
30 | 1 | 200ns | $Error::THROWN = undef; # last error thrown, a workaround until die $ref works | ||
31 | |||||
32 | 1 | 100ns | my $LAST; # Last error created | ||
33 | 1 | 200ns | my %ERROR; # Last error associated with package | ||
34 | |||||
35 | sub _throw_Error_Simple | ||||
36 | { | ||||
37 | my $args = shift; | ||||
38 | return Error::Simple->new($args->{'text'}); | ||||
39 | } | ||||
40 | |||||
41 | 1 | 1µs | $Error::ObjectifyCallback = \&_throw_Error_Simple; | ||
42 | |||||
43 | |||||
44 | # Exported subs are defined in Error::subs | ||||
45 | |||||
46 | 2 | 739µs | 1 | 4µs | # spent 4µs within Error::BEGIN@46 which was called:
# once (4µs+0s) by Bio::Root::Root::BEGIN@146 at line 46 # spent 4µs making 1 call to Error::BEGIN@46 |
47 | |||||
48 | # spent 277µs (22+255) within Error::import which was called:
# once (22µs+255µs) by Bio::Root::Root::BEGIN@146 at line 159 of Bio/Root/Root.pm | ||||
49 | 5 | 19µs | shift; | ||
50 | my @tags = @_; | ||||
51 | local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; | ||||
52 | |||||
53 | @tags = grep { | ||||
54 | 2 | 1µs | if( $_ eq ':warndie' ) { | ||
55 | Error::WarnDie->import(); | ||||
56 | 0; | ||||
57 | } | ||||
58 | else { | ||||
59 | 1; | ||||
60 | } | ||||
61 | } @tags; | ||||
62 | |||||
63 | 1 | 255µs | Error::subs->import(@tags); # spent 255µs making 1 call to Exporter::import | ||
64 | } | ||||
65 | |||||
66 | # I really want to use last for the name of this method, but it is a keyword | ||||
67 | # which prevent the syntax last Error | ||||
68 | |||||
69 | sub prior { | ||||
70 | shift; # ignore | ||||
71 | |||||
72 | return $LAST unless @_; | ||||
73 | |||||
74 | my $pkg = shift; | ||||
75 | return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef | ||||
76 | unless ref($pkg); | ||||
77 | |||||
78 | my $obj = $pkg; | ||||
79 | my $err = undef; | ||||
80 | if($obj->isa('HASH')) { | ||||
81 | $err = $obj->{'__Error__'} | ||||
82 | if exists $obj->{'__Error__'}; | ||||
83 | } | ||||
84 | elsif($obj->isa('GLOB')) { | ||||
85 | $err = ${*$obj}{'__Error__'} | ||||
86 | if exists ${*$obj}{'__Error__'}; | ||||
87 | } | ||||
88 | |||||
89 | $err; | ||||
90 | } | ||||
91 | |||||
92 | sub flush { | ||||
93 | shift; #ignore | ||||
94 | |||||
95 | unless (@_) { | ||||
96 | $LAST = undef; | ||||
97 | return; | ||||
98 | } | ||||
99 | |||||
100 | my $pkg = shift; | ||||
101 | return unless ref($pkg); | ||||
102 | |||||
103 | undef $ERROR{$pkg} if defined $ERROR{$pkg}; | ||||
104 | } | ||||
105 | |||||
106 | # Return as much information as possible about where the error | ||||
107 | # happened. The -stacktrace element only exists if $Error::DEBUG | ||||
108 | # was set when the error was created | ||||
109 | |||||
110 | sub stacktrace { | ||||
111 | my $self = shift; | ||||
112 | |||||
113 | return $self->{'-stacktrace'} | ||||
114 | if exists $self->{'-stacktrace'}; | ||||
115 | |||||
116 | my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; | ||||
117 | |||||
118 | $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) | ||||
119 | unless($text =~ /\n$/s); | ||||
120 | |||||
121 | $text; | ||||
122 | } | ||||
123 | |||||
124 | |||||
125 | sub associate { | ||||
126 | my $err = shift; | ||||
127 | my $obj = shift; | ||||
128 | |||||
129 | return unless ref($obj); | ||||
130 | |||||
131 | if($obj->isa('HASH')) { | ||||
132 | $obj->{'__Error__'} = $err; | ||||
133 | } | ||||
134 | elsif($obj->isa('GLOB')) { | ||||
135 | ${*$obj}{'__Error__'} = $err; | ||||
136 | } | ||||
137 | $obj = ref($obj); | ||||
138 | $ERROR{ ref($obj) } = $err; | ||||
139 | |||||
140 | return; | ||||
141 | } | ||||
142 | |||||
143 | |||||
144 | sub new { | ||||
145 | my $self = shift; | ||||
146 | my($pkg,$file,$line) = caller($Error::Depth); | ||||
147 | |||||
148 | my $err = bless { | ||||
149 | '-package' => $pkg, | ||||
150 | '-file' => $file, | ||||
151 | '-line' => $line, | ||||
152 | @_ | ||||
153 | }, $self; | ||||
154 | |||||
155 | $err->associate($err->{'-object'}) | ||||
156 | if(exists $err->{'-object'}); | ||||
157 | |||||
158 | # To always create a stacktrace would be very inefficient, so | ||||
159 | # we only do it if $Error::Debug is set | ||||
160 | |||||
161 | if($Error::Debug) { | ||||
162 | require Carp; | ||||
163 | local $Carp::CarpLevel = $Error::Depth; | ||||
164 | my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; | ||||
165 | my $trace = Carp::longmess($text); | ||||
166 | # Remove try calls from the trace | ||||
167 | $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; | ||||
168 | $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; | ||||
169 | $err->{'-stacktrace'} = $trace | ||||
170 | } | ||||
171 | |||||
172 | $@ = $LAST = $ERROR{$pkg} = $err; | ||||
173 | } | ||||
174 | |||||
175 | # Throw an error. this contains some very gory code. | ||||
176 | |||||
177 | sub throw { | ||||
178 | my $self = shift; | ||||
179 | local $Error::Depth = $Error::Depth + 1; | ||||
180 | |||||
181 | # if we are not rethrow-ing then create the object to throw | ||||
182 | $self = $self->new(@_) unless ref($self); | ||||
183 | |||||
184 | die $Error::THROWN = $self; | ||||
185 | } | ||||
186 | |||||
187 | # syntactic sugar for | ||||
188 | # | ||||
189 | # die with Error( ... ); | ||||
190 | |||||
191 | sub with { | ||||
192 | my $self = shift; | ||||
193 | local $Error::Depth = $Error::Depth + 1; | ||||
194 | |||||
195 | $self->new(@_); | ||||
196 | } | ||||
197 | |||||
198 | # syntactic sugar for | ||||
199 | # | ||||
200 | # record Error( ... ) and return; | ||||
201 | |||||
202 | sub record { | ||||
203 | my $self = shift; | ||||
204 | local $Error::Depth = $Error::Depth + 1; | ||||
205 | |||||
206 | $self->new(@_); | ||||
207 | } | ||||
208 | |||||
209 | # catch clause for | ||||
210 | # | ||||
211 | # try { ... } catch CLASS with { ... } | ||||
212 | |||||
213 | sub catch { | ||||
214 | my $pkg = shift; | ||||
215 | my $code = shift; | ||||
216 | my $clauses = shift || {}; | ||||
217 | my $catch = $clauses->{'catch'} ||= []; | ||||
218 | |||||
219 | unshift @$catch, $pkg, $code; | ||||
220 | |||||
221 | $clauses; | ||||
222 | } | ||||
223 | |||||
224 | # Object query methods | ||||
225 | |||||
226 | sub object { | ||||
227 | my $self = shift; | ||||
228 | exists $self->{'-object'} ? $self->{'-object'} : undef; | ||||
229 | } | ||||
230 | |||||
231 | sub file { | ||||
232 | my $self = shift; | ||||
233 | exists $self->{'-file'} ? $self->{'-file'} : undef; | ||||
234 | } | ||||
235 | |||||
236 | sub line { | ||||
237 | my $self = shift; | ||||
238 | exists $self->{'-line'} ? $self->{'-line'} : undef; | ||||
239 | } | ||||
240 | |||||
241 | sub text { | ||||
242 | my $self = shift; | ||||
243 | exists $self->{'-text'} ? $self->{'-text'} : undef; | ||||
244 | } | ||||
245 | |||||
246 | # overload methods | ||||
247 | |||||
248 | sub stringify { | ||||
249 | my $self = shift; | ||||
250 | defined $self->{'-text'} ? $self->{'-text'} : "Died"; | ||||
251 | } | ||||
252 | |||||
253 | sub value { | ||||
254 | my $self = shift; | ||||
255 | exists $self->{'-value'} ? $self->{'-value'} : undef; | ||||
256 | } | ||||
257 | |||||
258 | package Error::Simple; | ||||
259 | |||||
260 | 2 | 179µs | 2 | 48µs | # spent 28µs (8+20) within Error::Simple::BEGIN@260 which was called:
# once (8µs+20µs) by Bio::Root::Root::BEGIN@146 at line 260 # spent 28µs making 1 call to Error::Simple::BEGIN@260
# spent 20µs making 1 call to vars::import |
261 | |||||
262 | 1 | 600ns | $VERSION = "0.17021"; | ||
263 | |||||
264 | 1 | 10µs | @Error::Simple::ISA = qw(Error); | ||
265 | |||||
266 | sub new { | ||||
267 | my $self = shift; | ||||
268 | my $text = "" . shift; | ||||
269 | my $value = shift; | ||||
270 | my(@args) = (); | ||||
271 | |||||
272 | local $Error::Depth = $Error::Depth + 1; | ||||
273 | |||||
274 | @args = ( -file => $1, -line => $2) | ||||
275 | if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); | ||||
276 | push(@args, '-value', 0 + $value) | ||||
277 | if defined($value); | ||||
278 | |||||
279 | $self->SUPER::new(-text => $text, @args); | ||||
280 | } | ||||
281 | |||||
282 | sub stringify { | ||||
283 | my $self = shift; | ||||
284 | my $text = $self->SUPER::stringify; | ||||
285 | $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) | ||||
286 | unless($text =~ /\n$/s); | ||||
287 | $text; | ||||
288 | } | ||||
289 | |||||
290 | ########################################################################## | ||||
291 | ########################################################################## | ||||
292 | |||||
293 | # Inspired by code from Jesse Glick <jglick@sig.bsh.com> and | ||||
294 | # Peter Seibel <peter@weblogic.com> | ||||
295 | |||||
296 | package Error::subs; | ||||
297 | |||||
298 | 2 | 24µs | 1 | 5µs | # spent 5µs within Error::subs::BEGIN@298 which was called:
# once (5µs+0s) by Bio::Root::Root::BEGIN@146 at line 298 # spent 5µs making 1 call to Error::subs::BEGIN@298 |
299 | 2 | 1.48ms | 2 | 87µs | # spent 47µs (7+40) within Error::subs::BEGIN@299 which was called:
# once (7µs+40µs) by Bio::Root::Root::BEGIN@146 at line 299 # spent 47µs making 1 call to Error::subs::BEGIN@299
# spent 40µs making 1 call to vars::import |
300 | |||||
301 | 1 | 2µs | @EXPORT_OK = qw(try with finally except otherwise); | ||
302 | 1 | 2µs | %EXPORT_TAGS = (try => \@EXPORT_OK); | ||
303 | |||||
304 | 1 | 7µs | @ISA = qw(Exporter); | ||
305 | |||||
306 | sub run_clauses ($$$\@) { | ||||
307 | my($clauses,$err,$wantarray,$result) = @_; | ||||
308 | my $code = undef; | ||||
309 | |||||
310 | $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err); | ||||
311 | |||||
312 | CATCH: { | ||||
313 | |||||
314 | # catch | ||||
315 | my $catch; | ||||
316 | if(defined($catch = $clauses->{'catch'})) { | ||||
317 | my $i = 0; | ||||
318 | |||||
319 | CATCHLOOP: | ||||
320 | for( ; $i < @$catch ; $i += 2) { | ||||
321 | my $pkg = $catch->[$i]; | ||||
322 | unless(defined $pkg) { | ||||
323 | #except | ||||
324 | splice(@$catch,$i,2,$catch->[$i+1]->($err)); | ||||
325 | $i -= 2; | ||||
326 | next CATCHLOOP; | ||||
327 | } | ||||
328 | elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { | ||||
329 | $code = $catch->[$i+1]; | ||||
330 | while(1) { | ||||
331 | my $more = 0; | ||||
332 | local($Error::THROWN, $@); | ||||
333 | my $ok = eval { | ||||
334 | $@ = $err; | ||||
335 | if($wantarray) { | ||||
336 | @{$result} = $code->($err,\$more); | ||||
337 | } | ||||
338 | elsif(defined($wantarray)) { | ||||
339 | @{$result} = (); | ||||
340 | $result->[0] = $code->($err,\$more); | ||||
341 | } | ||||
342 | else { | ||||
343 | $code->($err,\$more); | ||||
344 | } | ||||
345 | 1; | ||||
346 | }; | ||||
347 | if( $ok ) { | ||||
348 | next CATCHLOOP if $more; | ||||
349 | undef $err; | ||||
350 | } | ||||
351 | else { | ||||
352 | $err = $@ || $Error::THROWN; | ||||
353 | $err = $Error::ObjectifyCallback->({'text' =>$err}) | ||||
354 | unless ref($err); | ||||
355 | } | ||||
356 | last CATCH; | ||||
357 | }; | ||||
358 | } | ||||
359 | } | ||||
360 | } | ||||
361 | |||||
362 | # otherwise | ||||
363 | my $owise; | ||||
364 | if(defined($owise = $clauses->{'otherwise'})) { | ||||
365 | my $code = $clauses->{'otherwise'}; | ||||
366 | my $more = 0; | ||||
367 | local($Error::THROWN, $@); | ||||
368 | my $ok = eval { | ||||
369 | $@ = $err; | ||||
370 | if($wantarray) { | ||||
371 | @{$result} = $code->($err,\$more); | ||||
372 | } | ||||
373 | elsif(defined($wantarray)) { | ||||
374 | @{$result} = (); | ||||
375 | $result->[0] = $code->($err,\$more); | ||||
376 | } | ||||
377 | else { | ||||
378 | $code->($err,\$more); | ||||
379 | } | ||||
380 | 1; | ||||
381 | }; | ||||
382 | if( $ok ) { | ||||
383 | undef $err; | ||||
384 | } | ||||
385 | else { | ||||
386 | $err = $@ || $Error::THROWN; | ||||
387 | |||||
388 | $err = $Error::ObjectifyCallback->({'text' =>$err}) | ||||
389 | unless ref($err); | ||||
390 | } | ||||
391 | } | ||||
392 | } | ||||
393 | $err; | ||||
394 | } | ||||
395 | |||||
396 | sub try (&;$) { | ||||
397 | my $try = shift; | ||||
398 | my $clauses = @_ ? shift : {}; | ||||
399 | my $ok = 0; | ||||
400 | my $err = undef; | ||||
401 | my @result = (); | ||||
402 | |||||
403 | unshift @Error::STACK, $clauses; | ||||
404 | |||||
405 | my $wantarray = wantarray(); | ||||
406 | |||||
407 | do { | ||||
408 | local $Error::THROWN = undef; | ||||
409 | local $@ = undef; | ||||
410 | |||||
411 | $ok = eval { | ||||
412 | if($wantarray) { | ||||
413 | @result = $try->(); | ||||
414 | } | ||||
415 | elsif(defined $wantarray) { | ||||
416 | $result[0] = $try->(); | ||||
417 | } | ||||
418 | else { | ||||
419 | $try->(); | ||||
420 | } | ||||
421 | 1; | ||||
422 | }; | ||||
423 | |||||
424 | $err = $@ || $Error::THROWN | ||||
425 | unless $ok; | ||||
426 | }; | ||||
427 | |||||
428 | shift @Error::STACK; | ||||
429 | |||||
430 | $err = run_clauses($clauses,$err,wantarray,@result) | ||||
431 | unless($ok); | ||||
432 | |||||
433 | $clauses->{'finally'}->() | ||||
434 | if(defined($clauses->{'finally'})); | ||||
435 | |||||
436 | if (defined($err)) | ||||
437 | { | ||||
438 | if (Scalar::Util::blessed($err) && $err->can('throw')) | ||||
439 | { | ||||
440 | throw $err; | ||||
441 | } | ||||
442 | else | ||||
443 | { | ||||
444 | die $err; | ||||
445 | } | ||||
446 | } | ||||
447 | |||||
448 | wantarray ? @result : $result[0]; | ||||
449 | } | ||||
450 | |||||
451 | # Each clause adds a sub to the list of clauses. The finally clause is | ||||
452 | # always the last, and the otherwise clause is always added just before | ||||
453 | # the finally clause. | ||||
454 | # | ||||
455 | # All clauses, except the finally clause, add a sub which takes one argument | ||||
456 | # this argument will be the error being thrown. The sub will return a code ref | ||||
457 | # if that clause can handle that error, otherwise undef is returned. | ||||
458 | # | ||||
459 | # The otherwise clause adds a sub which unconditionally returns the users | ||||
460 | # code reference, this is why it is forced to be last. | ||||
461 | # | ||||
462 | # The catch clause is defined in Error.pm, as the syntax causes it to | ||||
463 | # be called as a method | ||||
464 | |||||
465 | sub with (&;$) { | ||||
466 | @_ | ||||
467 | } | ||||
468 | |||||
469 | sub finally (&) { | ||||
470 | my $code = shift; | ||||
471 | my $clauses = { 'finally' => $code }; | ||||
472 | $clauses; | ||||
473 | } | ||||
474 | |||||
475 | # The except clause is a block which returns a hashref or a list of | ||||
476 | # key-value pairs, where the keys are the classes and the values are subs. | ||||
477 | |||||
478 | sub except (&;$) { | ||||
479 | my $code = shift; | ||||
480 | my $clauses = shift || {}; | ||||
481 | my $catch = $clauses->{'catch'} ||= []; | ||||
482 | |||||
483 | my $sub = sub { | ||||
484 | my $ref; | ||||
485 | my(@array) = $code->($_[0]); | ||||
486 | if(@array == 1 && ref($array[0])) { | ||||
487 | $ref = $array[0]; | ||||
488 | $ref = [ %$ref ] | ||||
489 | if(UNIVERSAL::isa($ref,'HASH')); | ||||
490 | } | ||||
491 | else { | ||||
492 | $ref = \@array; | ||||
493 | } | ||||
494 | @$ref | ||||
495 | }; | ||||
496 | |||||
497 | unshift @{$catch}, undef, $sub; | ||||
498 | |||||
499 | $clauses; | ||||
500 | } | ||||
501 | |||||
502 | sub otherwise (&;$) { | ||||
503 | my $code = shift; | ||||
504 | my $clauses = shift || {}; | ||||
505 | |||||
506 | if(exists $clauses->{'otherwise'}) { | ||||
507 | require Carp; | ||||
508 | Carp::croak("Multiple otherwise clauses"); | ||||
509 | } | ||||
510 | |||||
511 | $clauses->{'otherwise'} = $code; | ||||
512 | |||||
513 | $clauses; | ||||
514 | } | ||||
515 | |||||
516 | 1; | ||||
517 | |||||
518 | package Error::WarnDie; | ||||
519 | |||||
520 | sub gen_callstack($) | ||||
521 | { | ||||
522 | my ( $start ) = @_; | ||||
523 | |||||
524 | require Carp; | ||||
525 | local $Carp::CarpLevel = $start; | ||||
526 | my $trace = Carp::longmess(""); | ||||
527 | # Remove try calls from the trace | ||||
528 | $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; | ||||
529 | $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::run_clauses[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; | ||||
530 | my @callstack = split( m/\n/, $trace ); | ||||
531 | return @callstack; | ||||
532 | } | ||||
533 | |||||
534 | 1 | 100ns | my $old_DIE; | ||
535 | 1 | 100ns | my $old_WARN; | ||
536 | |||||
537 | sub DEATH | ||||
538 | { | ||||
539 | my ( $e ) = @_; | ||||
540 | |||||
541 | local $SIG{__DIE__} = $old_DIE if( defined $old_DIE ); | ||||
542 | |||||
543 | die @_ if $^S; | ||||
544 | |||||
545 | my ( $etype, $message, $location, @callstack ); | ||||
546 | if ( ref($e) && $e->isa( "Error" ) ) { | ||||
547 | $etype = "exception of type " . ref( $e ); | ||||
548 | $message = $e->text; | ||||
549 | $location = $e->file . ":" . $e->line; | ||||
550 | @callstack = split( m/\n/, $e->stacktrace ); | ||||
551 | } | ||||
552 | else { | ||||
553 | # Don't apply subsequent layer of message formatting | ||||
554 | die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ ); | ||||
555 | $etype = "perl error"; | ||||
556 | my $stackdepth = 0; | ||||
557 | while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) { | ||||
558 | $stackdepth++ | ||||
559 | } | ||||
560 | |||||
561 | @callstack = gen_callstack( $stackdepth + 1 ); | ||||
562 | |||||
563 | $message = "$e"; | ||||
564 | chomp $message; | ||||
565 | |||||
566 | if ( $message =~ s/ at (.*?) line (\d+)\.$// ) { | ||||
567 | $location = $1 . ":" . $2; | ||||
568 | } | ||||
569 | else { | ||||
570 | my @caller = caller( $stackdepth ); | ||||
571 | $location = $caller[1] . ":" . $caller[2]; | ||||
572 | } | ||||
573 | } | ||||
574 | |||||
575 | shift @callstack; | ||||
576 | # Do it this way in case there are no elements; we don't print a spurious \n | ||||
577 | my $callstack = join( "", map { "$_\n"} @callstack ); | ||||
578 | |||||
579 | die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n"; | ||||
580 | } | ||||
581 | |||||
582 | sub TAXES | ||||
583 | { | ||||
584 | my ( $message ) = @_; | ||||
585 | |||||
586 | local $SIG{__WARN__} = $old_WARN if( defined $old_WARN ); | ||||
587 | |||||
588 | $message =~ s/ at .*? line \d+\.$//; | ||||
589 | chomp $message; | ||||
590 | |||||
591 | my @callstack = gen_callstack( 1 ); | ||||
592 | my $location = shift @callstack; | ||||
593 | |||||
594 | # $location already starts in a leading space | ||||
595 | $message .= $location; | ||||
596 | |||||
597 | # Do it this way in case there are no elements; we don't print a spurious \n | ||||
598 | my $callstack = join( "", map { "$_\n"} @callstack ); | ||||
599 | |||||
600 | warn "$message:\n$callstack"; | ||||
601 | } | ||||
602 | |||||
603 | sub import | ||||
604 | { | ||||
605 | $old_DIE = $SIG{__DIE__}; | ||||
606 | $old_WARN = $SIG{__WARN__}; | ||||
607 | |||||
608 | $SIG{__DIE__} = \&DEATH; | ||||
609 | $SIG{__WARN__} = \&TAXES; | ||||
610 | } | ||||
611 | |||||
612 | 1 | 25µs | 1; | ||
613 | |||||
614 | __END__ |