]>
Commit | Line | Data |
---|---|---|
5c4082fd PB |
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 | use strict; | |
e5741c36 ÆAB |
15 | use warnings; |
16 | ||
5c4082fd PB |
17 | use vars qw($VERSION); |
18 | use 5.004; | |
19 | ||
e5741c36 | 20 | $VERSION = "0.17025"; |
5c4082fd PB |
21 | |
22 | use overload ( | |
23 | '""' => 'stringify', | |
24 | '0+' => 'value', | |
25 | 'bool' => sub { return 1; }, | |
26 | 'fallback' => 1 | |
27 | ); | |
28 | ||
29 | $Error::Depth = 0; # Depth to pass to caller() | |
30 | $Error::Debug = 0; # Generate verbose stack traces | |
31 | @Error::STACK = (); # Clause stack for try | |
32 | $Error::THROWN = undef; # last error thrown, a workaround until die $ref works | |
33 | ||
34 | my $LAST; # Last error created | |
35 | my %ERROR; # Last error associated with package | |
36 | ||
e5741c36 | 37 | sub _throw_Error_Simple |
5c4082fd PB |
38 | { |
39 | my $args = shift; | |
40 | return Error::Simple->new($args->{'text'}); | |
41 | } | |
42 | ||
e5741c36 | 43 | $Error::ObjectifyCallback = \&_throw_Error_Simple; |
5c4082fd PB |
44 | |
45 | ||
46 | # Exported subs are defined in Error::subs | |
47 | ||
e5741c36 ÆAB |
48 | use Scalar::Util (); |
49 | ||
5c4082fd PB |
50 | sub import { |
51 | shift; | |
e5741c36 | 52 | my @tags = @_; |
5c4082fd | 53 | local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; |
e5741c36 ÆAB |
54 | |
55 | @tags = grep { | |
56 | if( $_ eq ':warndie' ) { | |
57 | Error::WarnDie->import(); | |
58 | 0; | |
59 | } | |
60 | else { | |
61 | 1; | |
62 | } | |
63 | } @tags; | |
64 | ||
65 | Error::subs->import(@tags); | |
5c4082fd PB |
66 | } |
67 | ||
68 | # I really want to use last for the name of this method, but it is a keyword | |
69 | # which prevent the syntax last Error | |
70 | ||
71 | sub prior { | |
72 | shift; # ignore | |
73 | ||
74 | return $LAST unless @_; | |
75 | ||
76 | my $pkg = shift; | |
77 | return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef | |
78 | unless ref($pkg); | |
79 | ||
80 | my $obj = $pkg; | |
81 | my $err = undef; | |
82 | if($obj->isa('HASH')) { | |
83 | $err = $obj->{'__Error__'} | |
84 | if exists $obj->{'__Error__'}; | |
85 | } | |
86 | elsif($obj->isa('GLOB')) { | |
87 | $err = ${*$obj}{'__Error__'} | |
88 | if exists ${*$obj}{'__Error__'}; | |
89 | } | |
90 | ||
91 | $err; | |
92 | } | |
93 | ||
94 | sub flush { | |
95 | shift; #ignore | |
96 | ||
97 | unless (@_) { | |
98 | $LAST = undef; | |
99 | return; | |
100 | } | |
101 | ||
102 | my $pkg = shift; | |
103 | return unless ref($pkg); | |
104 | ||
105 | undef $ERROR{$pkg} if defined $ERROR{$pkg}; | |
106 | } | |
107 | ||
108 | # Return as much information as possible about where the error | |
109 | # happened. The -stacktrace element only exists if $Error::DEBUG | |
110 | # was set when the error was created | |
111 | ||
112 | sub stacktrace { | |
113 | my $self = shift; | |
114 | ||
115 | return $self->{'-stacktrace'} | |
116 | if exists $self->{'-stacktrace'}; | |
117 | ||
118 | my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died"; | |
119 | ||
120 | $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) | |
121 | unless($text =~ /\n$/s); | |
122 | ||
123 | $text; | |
124 | } | |
125 | ||
5c4082fd PB |
126 | |
127 | sub associate { | |
128 | my $err = shift; | |
129 | my $obj = shift; | |
130 | ||
131 | return unless ref($obj); | |
132 | ||
133 | if($obj->isa('HASH')) { | |
134 | $obj->{'__Error__'} = $err; | |
135 | } | |
136 | elsif($obj->isa('GLOB')) { | |
137 | ${*$obj}{'__Error__'} = $err; | |
138 | } | |
139 | $obj = ref($obj); | |
140 | $ERROR{ ref($obj) } = $err; | |
141 | ||
142 | return; | |
143 | } | |
144 | ||
e5741c36 | 145 | |
5c4082fd PB |
146 | sub new { |
147 | my $self = shift; | |
148 | my($pkg,$file,$line) = caller($Error::Depth); | |
149 | ||
150 | my $err = bless { | |
151 | '-package' => $pkg, | |
152 | '-file' => $file, | |
153 | '-line' => $line, | |
154 | @_ | |
155 | }, $self; | |
156 | ||
157 | $err->associate($err->{'-object'}) | |
158 | if(exists $err->{'-object'}); | |
159 | ||
160 | # To always create a stacktrace would be very inefficient, so | |
161 | # we only do it if $Error::Debug is set | |
162 | ||
163 | if($Error::Debug) { | |
164 | require Carp; | |
165 | local $Carp::CarpLevel = $Error::Depth; | |
166 | my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error"; | |
167 | my $trace = Carp::longmess($text); | |
168 | # Remove try calls from the trace | |
169 | $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; | |
170 | $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; | |
171 | $err->{'-stacktrace'} = $trace | |
172 | } | |
173 | ||
174 | $@ = $LAST = $ERROR{$pkg} = $err; | |
175 | } | |
176 | ||
177 | # Throw an error. this contains some very gory code. | |
178 | ||
179 | sub throw { | |
180 | my $self = shift; | |
181 | local $Error::Depth = $Error::Depth + 1; | |
182 | ||
183 | # if we are not rethrow-ing then create the object to throw | |
184 | $self = $self->new(@_) unless ref($self); | |
185 | ||
186 | die $Error::THROWN = $self; | |
187 | } | |
188 | ||
189 | # syntactic sugar for | |
190 | # | |
191 | # die with Error( ... ); | |
192 | ||
193 | sub with { | |
194 | my $self = shift; | |
195 | local $Error::Depth = $Error::Depth + 1; | |
196 | ||
197 | $self->new(@_); | |
198 | } | |
199 | ||
200 | # syntactic sugar for | |
201 | # | |
202 | # record Error( ... ) and return; | |
203 | ||
204 | sub record { | |
205 | my $self = shift; | |
206 | local $Error::Depth = $Error::Depth + 1; | |
207 | ||
208 | $self->new(@_); | |
209 | } | |
210 | ||
211 | # catch clause for | |
212 | # | |
213 | # try { ... } catch CLASS with { ... } | |
214 | ||
215 | sub catch { | |
216 | my $pkg = shift; | |
217 | my $code = shift; | |
218 | my $clauses = shift || {}; | |
219 | my $catch = $clauses->{'catch'} ||= []; | |
220 | ||
221 | unshift @$catch, $pkg, $code; | |
222 | ||
223 | $clauses; | |
224 | } | |
225 | ||
226 | # Object query methods | |
227 | ||
228 | sub object { | |
229 | my $self = shift; | |
230 | exists $self->{'-object'} ? $self->{'-object'} : undef; | |
231 | } | |
232 | ||
233 | sub file { | |
234 | my $self = shift; | |
235 | exists $self->{'-file'} ? $self->{'-file'} : undef; | |
236 | } | |
237 | ||
238 | sub line { | |
239 | my $self = shift; | |
240 | exists $self->{'-line'} ? $self->{'-line'} : undef; | |
241 | } | |
242 | ||
243 | sub text { | |
244 | my $self = shift; | |
245 | exists $self->{'-text'} ? $self->{'-text'} : undef; | |
246 | } | |
247 | ||
248 | # overload methods | |
249 | ||
250 | sub stringify { | |
251 | my $self = shift; | |
252 | defined $self->{'-text'} ? $self->{'-text'} : "Died"; | |
253 | } | |
254 | ||
255 | sub value { | |
256 | my $self = shift; | |
257 | exists $self->{'-value'} ? $self->{'-value'} : undef; | |
258 | } | |
259 | ||
260 | package Error::Simple; | |
261 | ||
e5741c36 ÆAB |
262 | use vars qw($VERSION); |
263 | ||
264 | $VERSION = "0.17025"; | |
265 | ||
5c4082fd PB |
266 | @Error::Simple::ISA = qw(Error); |
267 | ||
268 | sub new { | |
269 | my $self = shift; | |
270 | my $text = "" . shift; | |
271 | my $value = shift; | |
272 | my(@args) = (); | |
273 | ||
274 | local $Error::Depth = $Error::Depth + 1; | |
275 | ||
276 | @args = ( -file => $1, -line => $2) | |
277 | if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s); | |
278 | push(@args, '-value', 0 + $value) | |
279 | if defined($value); | |
280 | ||
281 | $self->SUPER::new(-text => $text, @args); | |
282 | } | |
283 | ||
284 | sub stringify { | |
285 | my $self = shift; | |
286 | my $text = $self->SUPER::stringify; | |
287 | $text .= sprintf(" at %s line %d.\n", $self->file, $self->line) | |
288 | unless($text =~ /\n$/s); | |
289 | $text; | |
290 | } | |
291 | ||
292 | ########################################################################## | |
293 | ########################################################################## | |
294 | ||
295 | # Inspired by code from Jesse Glick <jglick@sig.bsh.com> and | |
296 | # Peter Seibel <peter@weblogic.com> | |
297 | ||
298 | package Error::subs; | |
299 | ||
300 | use Exporter (); | |
301 | use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS); | |
302 | ||
303 | @EXPORT_OK = qw(try with finally except otherwise); | |
304 | %EXPORT_TAGS = (try => \@EXPORT_OK); | |
305 | ||
306 | @ISA = qw(Exporter); | |
307 | ||
308 | sub run_clauses ($$$\@) { | |
309 | my($clauses,$err,$wantarray,$result) = @_; | |
310 | my $code = undef; | |
311 | ||
312 | $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err); | |
313 | ||
314 | CATCH: { | |
315 | ||
316 | # catch | |
317 | my $catch; | |
318 | if(defined($catch = $clauses->{'catch'})) { | |
319 | my $i = 0; | |
320 | ||
321 | CATCHLOOP: | |
322 | for( ; $i < @$catch ; $i += 2) { | |
323 | my $pkg = $catch->[$i]; | |
324 | unless(defined $pkg) { | |
325 | #except | |
e5741c36 | 326 | splice(@$catch,$i,2,$catch->[$i+1]->($err)); |
5c4082fd PB |
327 | $i -= 2; |
328 | next CATCHLOOP; | |
329 | } | |
e5741c36 | 330 | elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) { |
5c4082fd PB |
331 | $code = $catch->[$i+1]; |
332 | while(1) { | |
333 | my $more = 0; | |
e5741c36 | 334 | local($Error::THROWN, $@); |
5c4082fd | 335 | my $ok = eval { |
e5741c36 | 336 | $@ = $err; |
5c4082fd PB |
337 | if($wantarray) { |
338 | @{$result} = $code->($err,\$more); | |
339 | } | |
340 | elsif(defined($wantarray)) { | |
341 | @{$result} = (); | |
342 | $result->[0] = $code->($err,\$more); | |
343 | } | |
344 | else { | |
345 | $code->($err,\$more); | |
346 | } | |
347 | 1; | |
348 | }; | |
349 | if( $ok ) { | |
350 | next CATCHLOOP if $more; | |
351 | undef $err; | |
352 | } | |
353 | else { | |
e5741c36 ÆAB |
354 | $err = $@ || $Error::THROWN; |
355 | $err = $Error::ObjectifyCallback->({'text' =>$err}) | |
356 | unless ref($err); | |
5c4082fd PB |
357 | } |
358 | last CATCH; | |
359 | }; | |
360 | } | |
361 | } | |
362 | } | |
363 | ||
364 | # otherwise | |
365 | my $owise; | |
366 | if(defined($owise = $clauses->{'otherwise'})) { | |
367 | my $code = $clauses->{'otherwise'}; | |
368 | my $more = 0; | |
e5741c36 | 369 | local($Error::THROWN, $@); |
5c4082fd | 370 | my $ok = eval { |
e5741c36 | 371 | $@ = $err; |
5c4082fd PB |
372 | if($wantarray) { |
373 | @{$result} = $code->($err,\$more); | |
374 | } | |
375 | elsif(defined($wantarray)) { | |
376 | @{$result} = (); | |
377 | $result->[0] = $code->($err,\$more); | |
378 | } | |
379 | else { | |
380 | $code->($err,\$more); | |
381 | } | |
382 | 1; | |
383 | }; | |
384 | if( $ok ) { | |
385 | undef $err; | |
386 | } | |
387 | else { | |
e5741c36 | 388 | $err = $@ || $Error::THROWN; |
5c4082fd | 389 | |
e5741c36 ÆAB |
390 | $err = $Error::ObjectifyCallback->({'text' =>$err}) |
391 | unless ref($err); | |
5c4082fd PB |
392 | } |
393 | } | |
394 | } | |
395 | $err; | |
396 | } | |
397 | ||
398 | sub try (&;$) { | |
399 | my $try = shift; | |
400 | my $clauses = @_ ? shift : {}; | |
401 | my $ok = 0; | |
402 | my $err = undef; | |
403 | my @result = (); | |
404 | ||
405 | unshift @Error::STACK, $clauses; | |
406 | ||
407 | my $wantarray = wantarray(); | |
408 | ||
409 | do { | |
410 | local $Error::THROWN = undef; | |
e5741c36 | 411 | local $@ = undef; |
5c4082fd PB |
412 | |
413 | $ok = eval { | |
414 | if($wantarray) { | |
415 | @result = $try->(); | |
416 | } | |
417 | elsif(defined $wantarray) { | |
418 | $result[0] = $try->(); | |
419 | } | |
420 | else { | |
421 | $try->(); | |
422 | } | |
423 | 1; | |
424 | }; | |
425 | ||
e5741c36 | 426 | $err = $@ || $Error::THROWN |
5c4082fd PB |
427 | unless $ok; |
428 | }; | |
429 | ||
430 | shift @Error::STACK; | |
431 | ||
432 | $err = run_clauses($clauses,$err,wantarray,@result) | |
e5741c36 | 433 | unless($ok); |
5c4082fd PB |
434 | |
435 | $clauses->{'finally'}->() | |
436 | if(defined($clauses->{'finally'})); | |
437 | ||
438 | if (defined($err)) | |
439 | { | |
e5741c36 | 440 | if (Scalar::Util::blessed($err) && $err->can('throw')) |
5c4082fd PB |
441 | { |
442 | throw $err; | |
443 | } | |
444 | else | |
445 | { | |
446 | die $err; | |
447 | } | |
448 | } | |
449 | ||
450 | wantarray ? @result : $result[0]; | |
451 | } | |
452 | ||
453 | # Each clause adds a sub to the list of clauses. The finally clause is | |
454 | # always the last, and the otherwise clause is always added just before | |
455 | # the finally clause. | |
456 | # | |
457 | # All clauses, except the finally clause, add a sub which takes one argument | |
458 | # this argument will be the error being thrown. The sub will return a code ref | |
459 | # if that clause can handle that error, otherwise undef is returned. | |
460 | # | |
461 | # The otherwise clause adds a sub which unconditionally returns the users | |
462 | # code reference, this is why it is forced to be last. | |
463 | # | |
464 | # The catch clause is defined in Error.pm, as the syntax causes it to | |
465 | # be called as a method | |
466 | ||
467 | sub with (&;$) { | |
468 | @_ | |
469 | } | |
470 | ||
471 | sub finally (&) { | |
472 | my $code = shift; | |
473 | my $clauses = { 'finally' => $code }; | |
474 | $clauses; | |
475 | } | |
476 | ||
477 | # The except clause is a block which returns a hashref or a list of | |
478 | # key-value pairs, where the keys are the classes and the values are subs. | |
479 | ||
480 | sub except (&;$) { | |
481 | my $code = shift; | |
482 | my $clauses = shift || {}; | |
483 | my $catch = $clauses->{'catch'} ||= []; | |
484 | ||
485 | my $sub = sub { | |
486 | my $ref; | |
487 | my(@array) = $code->($_[0]); | |
488 | if(@array == 1 && ref($array[0])) { | |
489 | $ref = $array[0]; | |
490 | $ref = [ %$ref ] | |
491 | if(UNIVERSAL::isa($ref,'HASH')); | |
492 | } | |
493 | else { | |
494 | $ref = \@array; | |
495 | } | |
496 | @$ref | |
497 | }; | |
498 | ||
499 | unshift @{$catch}, undef, $sub; | |
500 | ||
501 | $clauses; | |
502 | } | |
503 | ||
504 | sub otherwise (&;$) { | |
505 | my $code = shift; | |
506 | my $clauses = shift || {}; | |
507 | ||
508 | if(exists $clauses->{'otherwise'}) { | |
509 | require Carp; | |
510 | Carp::croak("Multiple otherwise clauses"); | |
511 | } | |
512 | ||
513 | $clauses->{'otherwise'} = $code; | |
514 | ||
515 | $clauses; | |
516 | } | |
517 | ||
518 | 1; | |
e5741c36 ÆAB |
519 | |
520 | package Error::WarnDie; | |
521 | ||
522 | sub gen_callstack($) | |
523 | { | |
524 | my ( $start ) = @_; | |
525 | ||
526 | require Carp; | |
527 | local $Carp::CarpLevel = $start; | |
528 | my $trace = Carp::longmess(""); | |
529 | # Remove try calls from the trace | |
530 | $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog; | |
531 | $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; | |
532 | my @callstack = split( m/\n/, $trace ); | |
533 | return @callstack; | |
534 | } | |
535 | ||
536 | my $old_DIE; | |
537 | my $old_WARN; | |
538 | ||
539 | sub DEATH | |
540 | { | |
541 | my ( $e ) = @_; | |
542 | ||
543 | local $SIG{__DIE__} = $old_DIE if( defined $old_DIE ); | |
544 | ||
545 | die @_ if $^S; | |
546 | ||
547 | my ( $etype, $message, $location, @callstack ); | |
548 | if ( ref($e) && $e->isa( "Error" ) ) { | |
549 | $etype = "exception of type " . ref( $e ); | |
550 | $message = $e->text; | |
551 | $location = $e->file . ":" . $e->line; | |
552 | @callstack = split( m/\n/, $e->stacktrace ); | |
553 | } | |
554 | else { | |
555 | # Don't apply subsequent layer of message formatting | |
556 | die $e if( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ ); | |
557 | $etype = "perl error"; | |
558 | my $stackdepth = 0; | |
559 | while( caller( $stackdepth ) =~ m/^Error(?:$|::)/ ) { | |
560 | $stackdepth++ | |
561 | } | |
562 | ||
563 | @callstack = gen_callstack( $stackdepth + 1 ); | |
564 | ||
565 | $message = "$e"; | |
566 | chomp $message; | |
567 | ||
568 | if ( $message =~ s/ at (.*?) line (\d+)\.$// ) { | |
569 | $location = $1 . ":" . $2; | |
570 | } | |
571 | else { | |
572 | my @caller = caller( $stackdepth ); | |
573 | $location = $caller[1] . ":" . $caller[2]; | |
574 | } | |
575 | } | |
576 | ||
577 | shift @callstack; | |
578 | # Do it this way in case there are no elements; we don't print a spurious \n | |
579 | my $callstack = join( "", map { "$_\n"} @callstack ); | |
580 | ||
581 | die "\nUnhandled $etype caught at toplevel:\n\n $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n"; | |
582 | } | |
583 | ||
584 | sub TAXES | |
585 | { | |
586 | my ( $message ) = @_; | |
587 | ||
588 | local $SIG{__WARN__} = $old_WARN if( defined $old_WARN ); | |
589 | ||
590 | $message =~ s/ at .*? line \d+\.$//; | |
591 | chomp $message; | |
592 | ||
593 | my @callstack = gen_callstack( 1 ); | |
594 | my $location = shift @callstack; | |
595 | ||
596 | # $location already starts in a leading space | |
597 | $message .= $location; | |
598 | ||
599 | # Do it this way in case there are no elements; we don't print a spurious \n | |
600 | my $callstack = join( "", map { "$_\n"} @callstack ); | |
601 | ||
602 | warn "$message:\n$callstack"; | |
603 | } | |
604 | ||
605 | sub import | |
606 | { | |
607 | $old_DIE = $SIG{__DIE__}; | |
608 | $old_WARN = $SIG{__WARN__}; | |
609 | ||
610 | $SIG{__DIE__} = \&DEATH; | |
611 | $SIG{__WARN__} = \&TAXES; | |
612 | } | |
613 | ||
614 | 1; | |
615 | ||
5c4082fd PB |
616 | __END__ |
617 | ||
618 | =head1 NAME | |
619 | ||
620 | Error - Error/exception handling in an OO-ish way | |
621 | ||
e5741c36 ÆAB |
622 | =head1 WARNING |
623 | ||
624 | Using the "Error" module is B<no longer recommended> due to the black-magical | |
625 | nature of its syntactic sugar, which often tends to break. Its maintainers | |
626 | have stopped actively writing code that uses it, and discourage people | |
627 | from doing so. See the "SEE ALSO" section below for better recommendations. | |
628 | ||
5c4082fd PB |
629 | =head1 SYNOPSIS |
630 | ||
631 | use Error qw(:try); | |
632 | ||
633 | throw Error::Simple( "A simple error"); | |
634 | ||
635 | sub xyz { | |
636 | ... | |
637 | record Error::Simple("A simple error") | |
638 | and return; | |
639 | } | |
640 | ||
641 | unlink($file) or throw Error::Simple("$file: $!",$!); | |
642 | ||
643 | try { | |
644 | do_some_stuff(); | |
645 | die "error!" if $condition; | |
e5741c36 | 646 | throw Error::Simple "Oops!" if $other_condition; |
5c4082fd PB |
647 | } |
648 | catch Error::IO with { | |
649 | my $E = shift; | |
650 | print STDERR "File ", $E->{'-file'}, " had a problem\n"; | |
651 | } | |
652 | except { | |
653 | my $E = shift; | |
654 | my $general_handler=sub {send_message $E->{-description}}; | |
655 | return { | |
656 | UserException1 => $general_handler, | |
657 | UserException2 => $general_handler | |
658 | }; | |
659 | } | |
660 | otherwise { | |
661 | print STDERR "Well I don't know what to say\n"; | |
662 | } | |
663 | finally { | |
664 | close_the_garage_door_already(); # Should be reliable | |
665 | }; # Don't forget the trailing ; or you might be surprised | |
666 | ||
667 | =head1 DESCRIPTION | |
668 | ||
669 | The C<Error> package provides two interfaces. Firstly C<Error> provides | |
670 | a procedural interface to exception handling. Secondly C<Error> is a | |
671 | base class for errors/exceptions that can either be thrown, for | |
672 | subsequent catch, or can simply be recorded. | |
673 | ||
674 | Errors in the class C<Error> should not be thrown directly, but the | |
675 | user should throw errors from a sub-class of C<Error>. | |
676 | ||
677 | =head1 PROCEDURAL INTERFACE | |
678 | ||
679 | C<Error> exports subroutines to perform exception handling. These will | |
680 | be exported if the C<:try> tag is used in the C<use> line. | |
681 | ||
682 | =over 4 | |
683 | ||
684 | =item try BLOCK CLAUSES | |
685 | ||
686 | C<try> is the main subroutine called by the user. All other subroutines | |
687 | exported are clauses to the try subroutine. | |
688 | ||
689 | The BLOCK will be evaluated and, if no error is throw, try will return | |
690 | the result of the block. | |
691 | ||
692 | C<CLAUSES> are the subroutines below, which describe what to do in the | |
693 | event of an error being thrown within BLOCK. | |
694 | ||
695 | =item catch CLASS with BLOCK | |
696 | ||
697 | This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)> | |
698 | to be caught and handled by evaluating C<BLOCK>. | |
699 | ||
700 | C<BLOCK> will be passed two arguments. The first will be the error | |
701 | being thrown. The second is a reference to a scalar variable. If this | |
702 | variable is set by the catch block then, on return from the catch | |
703 | block, try will continue processing as if the catch block was never | |
e5741c36 | 704 | found. The error will also be available in C<$@>. |
5c4082fd PB |
705 | |
706 | To propagate the error the catch block may call C<$err-E<gt>throw> | |
707 | ||
708 | If the scalar reference by the second argument is not set, and the | |
709 | error is not thrown. Then the current try block will return with the | |
710 | result from the catch block. | |
711 | ||
712 | =item except BLOCK | |
713 | ||
714 | When C<try> is looking for a handler, if an except clause is found | |
715 | C<BLOCK> is evaluated. The return value from this block should be a | |
716 | HASHREF or a list of key-value pairs, where the keys are class names | |
717 | and the values are CODE references for the handler of errors of that | |
718 | type. | |
719 | ||
720 | =item otherwise BLOCK | |
721 | ||
722 | Catch any error by executing the code in C<BLOCK> | |
723 | ||
724 | When evaluated C<BLOCK> will be passed one argument, which will be the | |
e5741c36 | 725 | error being processed. The error will also be available in C<$@>. |
5c4082fd PB |
726 | |
727 | Only one otherwise block may be specified per try block | |
728 | ||
729 | =item finally BLOCK | |
730 | ||
731 | Execute the code in C<BLOCK> either after the code in the try block has | |
732 | successfully completed, or if the try block throws an error then | |
733 | C<BLOCK> will be executed after the handler has completed. | |
734 | ||
735 | If the handler throws an error then the error will be caught, the | |
736 | finally block will be executed and the error will be re-thrown. | |
737 | ||
738 | Only one finally block may be specified per try block | |
739 | ||
740 | =back | |
741 | ||
e5741c36 ÆAB |
742 | =head1 COMPATIBILITY |
743 | ||
744 | L<Moose> exports a keyword called C<with> which clashes with Error's. This | |
745 | example returns a prototype mismatch error: | |
746 | ||
747 | package MyTest; | |
748 | ||
749 | use warnings; | |
750 | use Moose; | |
751 | use Error qw(:try); | |
752 | ||
753 | (Thanks to C<maik.hentsche@amd.com> for the report.). | |
754 | ||
5c4082fd PB |
755 | =head1 CLASS INTERFACE |
756 | ||
757 | =head2 CONSTRUCTORS | |
758 | ||
759 | The C<Error> object is implemented as a HASH. This HASH is initialized | |
e5741c36 | 760 | with the arguments that are passed to it's constructor. The elements |
5c4082fd PB |
761 | that are used by, or are retrievable by the C<Error> class are listed |
762 | below, other classes may add to these. | |
763 | ||
764 | -file | |
765 | -line | |
766 | -text | |
767 | -value | |
768 | -object | |
769 | ||
770 | If C<-file> or C<-line> are not specified in the constructor arguments | |
771 | then these will be initialized with the file name and line number where | |
772 | the constructor was called from. | |
773 | ||
774 | If the error is associated with an object then the object should be | |
775 | passed as the C<-object> argument. This will allow the C<Error> package | |
776 | to associate the error with the object. | |
777 | ||
778 | The C<Error> package remembers the last error created, and also the | |
779 | last error associated with a package. This could either be the last | |
780 | error created by a sub in that package, or the last error which passed | |
781 | an object blessed into that package as the C<-object> argument. | |
782 | ||
783 | =over 4 | |
784 | ||
e5741c36 ÆAB |
785 | =item Error->new() |
786 | ||
787 | See the Error::Simple documentation. | |
788 | ||
5c4082fd PB |
789 | =item throw ( [ ARGS ] ) |
790 | ||
791 | Create a new C<Error> object and throw an error, which will be caught | |
792 | by a surrounding C<try> block, if there is one. Otherwise it will cause | |
793 | the program to exit. | |
794 | ||
795 | C<throw> may also be called on an existing error to re-throw it. | |
796 | ||
797 | =item with ( [ ARGS ] ) | |
798 | ||
799 | Create a new C<Error> object and returns it. This is defined for | |
800 | syntactic sugar, eg | |
801 | ||
802 | die with Some::Error ( ... ); | |
803 | ||
804 | =item record ( [ ARGS ] ) | |
805 | ||
806 | Create a new C<Error> object and returns it. This is defined for | |
807 | syntactic sugar, eg | |
808 | ||
809 | record Some::Error ( ... ) | |
810 | and return; | |
811 | ||
812 | =back | |
813 | ||
814 | =head2 STATIC METHODS | |
815 | ||
816 | =over 4 | |
817 | ||
818 | =item prior ( [ PACKAGE ] ) | |
819 | ||
820 | Return the last error created, or the last error associated with | |
821 | C<PACKAGE> | |
822 | ||
823 | =item flush ( [ PACKAGE ] ) | |
824 | ||
825 | Flush the last error created, or the last error associated with | |
826 | C<PACKAGE>.It is necessary to clear the error stack before exiting the | |
827 | package or uncaught errors generated using C<record> will be reported. | |
828 | ||
829 | $Error->flush; | |
830 | ||
831 | =cut | |
832 | ||
833 | =back | |
834 | ||
835 | =head2 OBJECT METHODS | |
836 | ||
837 | =over 4 | |
838 | ||
839 | =item stacktrace | |
840 | ||
841 | If the variable C<$Error::Debug> was non-zero when the error was | |
842 | created, then C<stacktrace> returns a string created by calling | |
843 | C<Carp::longmess>. If the variable was zero the C<stacktrace> returns | |
844 | the text of the error appended with the filename and line number of | |
845 | where the error was created, providing the text does not end with a | |
846 | newline. | |
847 | ||
848 | =item object | |
849 | ||
850 | The object this error was associated with | |
851 | ||
852 | =item file | |
853 | ||
854 | The file where the constructor of this error was called from | |
855 | ||
856 | =item line | |
857 | ||
858 | The line where the constructor of this error was called from | |
859 | ||
860 | =item text | |
861 | ||
862 | The text of the error | |
863 | ||
e5741c36 ÆAB |
864 | =item $err->associate($obj) |
865 | ||
866 | Associates an error with an object to allow error propagation. I.e: | |
867 | ||
868 | $ber->encode(...) or | |
869 | return Error->prior($ber)->associate($ldap); | |
870 | ||
5c4082fd PB |
871 | =back |
872 | ||
873 | =head2 OVERLOAD METHODS | |
874 | ||
875 | =over 4 | |
876 | ||
877 | =item stringify | |
878 | ||
879 | A method that converts the object into a string. This method may simply | |
880 | return the same as the C<text> method, or it may append more | |
881 | information. For example the file name and line number. | |
882 | ||
883 | By default this method returns the C<-text> argument that was passed to | |
884 | the constructor, or the string C<"Died"> if none was given. | |
885 | ||
886 | =item value | |
887 | ||
888 | A method that will return a value that can be associated with the | |
889 | error. For example if an error was created due to the failure of a | |
890 | system call, then this may return the numeric value of C<$!> at the | |
891 | time. | |
892 | ||
893 | By default this method returns the C<-value> argument that was passed | |
894 | to the constructor. | |
895 | ||
896 | =back | |
897 | ||
898 | =head1 PRE-DEFINED ERROR CLASSES | |
899 | ||
e5741c36 | 900 | =head2 Error::Simple |
5c4082fd | 901 | |
e5741c36 | 902 | This class can be used to hold simple error strings and values. It's |
5c4082fd PB |
903 | constructor takes two arguments. The first is a text value, the second |
904 | is a numeric value. These values are what will be returned by the | |
905 | overload methods. | |
906 | ||
907 | If the text value ends with C<at file line 1> as $@ strings do, then | |
41ccfdd9 | 908 | this information will be used to set the C<-file> and C<-line> arguments |
5c4082fd PB |
909 | of the error object. |
910 | ||
911 | This class is used internally if an eval'd block die's with an error | |
912 | that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified) | |
913 | ||
5c4082fd PB |
914 | |
915 | =head1 $Error::ObjectifyCallback | |
916 | ||
917 | This variable holds a reference to a subroutine that converts errors that | |
918 | are plain strings to objects. It is used by Error.pm to convert textual | |
3dff5379 | 919 | errors to objects, and can be overridden by the user. |
5c4082fd PB |
920 | |
921 | It accepts a single argument which is a hash reference to named parameters. | |
922 | Currently the only named parameter passed is C<'text'> which is the text | |
923 | of the error, but others may be available in the future. | |
924 | ||
925 | For example the following code will cause Error.pm to throw objects of the | |
926 | class MyError::Bar by default: | |
927 | ||
928 | sub throw_MyError_Bar | |
929 | { | |
930 | my $args = shift; | |
931 | my $err = MyError::Bar->new(); | |
932 | $err->{'MyBarText'} = $args->{'text'}; | |
933 | return $err; | |
934 | } | |
935 | ||
936 | { | |
937 | local $Error::ObjectifyCallback = \&throw_MyError_Bar; | |
938 | ||
939 | # Error handling here. | |
940 | } | |
941 | ||
e5741c36 ÆAB |
942 | =cut |
943 | ||
944 | =head1 MESSAGE HANDLERS | |
945 | ||
946 | C<Error> also provides handlers to extend the output of the C<warn()> perl | |
947 | function, and to handle the printing of a thrown C<Error> that is not caught | |
948 | or otherwise handled. These are not installed by default, but are requested | |
949 | using the C<:warndie> tag in the C<use> line. | |
950 | ||
951 | use Error qw( :warndie ); | |
952 | ||
953 | These new error handlers are installed in C<$SIG{__WARN__}> and | |
954 | C<$SIG{__DIE__}>. If these handlers are already defined when the tag is | |
955 | imported, the old values are stored, and used during the new code. Thus, to | |
956 | arrange for custom handling of warnings and errors, you will need to perform | |
957 | something like the following: | |
958 | ||
959 | BEGIN { | |
960 | $SIG{__WARN__} = sub { | |
961 | print STDERR "My special warning handler: $_[0]" | |
962 | }; | |
963 | } | |
964 | ||
965 | use Error qw( :warndie ); | |
966 | ||
967 | Note that setting C<$SIG{__WARN__}> after the C<:warndie> tag has been | |
968 | imported will overwrite the handler that C<Error> provides. If this cannot be | |
969 | avoided, then the tag can be explicitly C<import>ed later | |
970 | ||
971 | use Error; | |
972 | ||
973 | $SIG{__WARN__} = ...; | |
974 | ||
975 | import Error qw( :warndie ); | |
976 | ||
977 | =head2 EXAMPLE | |
978 | ||
979 | The C<__DIE__> handler turns messages such as | |
980 | ||
981 | Can't call method "foo" on an undefined value at examples/warndie.pl line 16. | |
982 | ||
983 | into | |
984 | ||
985 | Unhandled perl error caught at toplevel: | |
986 | ||
987 | Can't call method "foo" on an undefined value | |
988 | ||
989 | Thrown from: examples/warndie.pl:16 | |
990 | ||
991 | Full stack trace: | |
992 | ||
993 | main::inner('undef') called at examples/warndie.pl line 20 | |
994 | main::outer('undef') called at examples/warndie.pl line 23 | |
995 | ||
996 | =cut | |
997 | ||
998 | =head1 SEE ALSO | |
999 | ||
1000 | See L<Exception::Class> for a different module providing Object-Oriented | |
1001 | exception handling, along with a convenient syntax for declaring hierarchies | |
1002 | for them. It doesn't provide Error's syntactic sugar of C<try { ... }>, | |
1003 | C<catch { ... }>, etc. which may be a good thing or a bad thing based | |
1004 | on what you want. (Because Error's syntactic sugar tends to break.) | |
1005 | ||
1006 | L<Error::Exception> aims to combine L<Error> and L<Exception::Class> | |
1007 | "with correct stringification". | |
1008 | ||
1009 | L<TryCatch> and L<Try::Tiny> are similar in concept to Error.pm only providing | |
1010 | a syntax that hopefully breaks less. | |
1011 | ||
5c4082fd PB |
1012 | =head1 KNOWN BUGS |
1013 | ||
1014 | None, but that does not mean there are not any. | |
1015 | ||
1016 | =head1 AUTHORS | |
1017 | ||
1018 | Graham Barr <gbarr@pobox.com> | |
1019 | ||
1020 | The code that inspired me to write this was originally written by | |
1021 | Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick | |
1022 | <jglick@sig.bsh.com>. | |
1023 | ||
e5741c36 ÆAB |
1024 | C<:warndie> handlers added by Paul Evans <leonerd@leonerd.org.uk> |
1025 | ||
5c4082fd PB |
1026 | =head1 MAINTAINER |
1027 | ||
e5741c36 | 1028 | Shlomi Fish, L<http://www.shlomifish.org/> . |
5c4082fd PB |
1029 | |
1030 | =head1 PAST MAINTAINERS | |
1031 | ||
1032 | Arun Kumar U <u_arunkumar@yahoo.com> | |
1033 | ||
e5741c36 ÆAB |
1034 | =head1 COPYRIGHT |
1035 | ||
1036 | Copyright (c) 1997-8 Graham Barr. All rights reserved. | |
1037 | This program is free software; you can redistribute it and/or modify it | |
1038 | under the same terms as Perl itself. | |
1039 | ||
5c4082fd | 1040 | =cut |