tgupdate: merge girocco base into girocco
[git/gitweb.git] / perl / private-Error.pm
blob6098135ae2b2d473729373b69e776f475cf919dd
1 # Error.pm
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.
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>.
10 # but modified ***significantly***
12 package Error;
14 use strict;
15 use vars qw($VERSION);
16 use 5.004;
18 $VERSION = "0.15009";
20 use overload (
21 '""' => 'stringify',
22 '0+' => 'value',
23 'bool' => sub { return 1; },
24 'fallback' => 1
27 $Error::Depth = 0; # Depth to pass to caller()
28 $Error::Debug = 0; # Generate verbose stack traces
29 @Error::STACK = (); # Clause stack for try
30 $Error::THROWN = undef; # last error thrown, a workaround until die $ref works
32 my $LAST; # Last error created
33 my %ERROR; # Last error associated with package
35 sub throw_Error_Simple
37 my $args = shift;
38 return Error::Simple->new($args->{'text'});
41 $Error::ObjectifyCallback = \&throw_Error_Simple;
44 # Exported subs are defined in Error::subs
46 sub import {
47 shift;
48 local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
49 Error::subs->import(@_);
52 # I really want to use last for the name of this method, but it is a keyword
53 # which prevent the syntax last Error
55 sub prior {
56 shift; # ignore
58 return $LAST unless @_;
60 my $pkg = shift;
61 return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
62 unless ref($pkg);
64 my $obj = $pkg;
65 my $err = undef;
66 if($obj->isa('HASH')) {
67 $err = $obj->{'__Error__'}
68 if exists $obj->{'__Error__'};
70 elsif($obj->isa('GLOB')) {
71 $err = ${*$obj}{'__Error__'}
72 if exists ${*$obj}{'__Error__'};
75 $err;
78 sub flush {
79 shift; #ignore
81 unless (@_) {
82 $LAST = undef;
83 return;
86 my $pkg = shift;
87 return unless ref($pkg);
89 undef $ERROR{$pkg} if defined $ERROR{$pkg};
92 # Return as much information as possible about where the error
93 # happened. The -stacktrace element only exists if $Error::DEBUG
94 # was set when the error was created
96 sub stacktrace {
97 my $self = shift;
99 return $self->{'-stacktrace'}
100 if exists $self->{'-stacktrace'};
102 my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
104 $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
105 unless($text =~ /\n$/s);
107 $text;
110 # Allow error propagation, ie
112 # $ber->encode(...) or
113 # return Error->prior($ber)->associate($ldap);
115 sub associate {
116 my $err = shift;
117 my $obj = shift;
119 return unless ref($obj);
121 if($obj->isa('HASH')) {
122 $obj->{'__Error__'} = $err;
124 elsif($obj->isa('GLOB')) {
125 ${*$obj}{'__Error__'} = $err;
127 $obj = ref($obj);
128 $ERROR{ ref($obj) } = $err;
130 return;
133 sub new {
134 my $self = shift;
135 my($pkg,$file,$line) = caller($Error::Depth);
137 my $err = bless {
138 '-package' => $pkg,
139 '-file' => $file,
140 '-line' => $line,
142 }, $self;
144 $err->associate($err->{'-object'})
145 if(exists $err->{'-object'});
147 # To always create a stacktrace would be very inefficient, so
148 # we only do it if $Error::Debug is set
150 if($Error::Debug) {
151 require Carp;
152 local $Carp::CarpLevel = $Error::Depth;
153 my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
154 my $trace = Carp::longmess($text);
155 # Remove try calls from the trace
156 $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
157 $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;
158 $err->{'-stacktrace'} = $trace
161 $@ = $LAST = $ERROR{$pkg} = $err;
164 # Throw an error. this contains some very gory code.
166 sub throw {
167 my $self = shift;
168 local $Error::Depth = $Error::Depth + 1;
170 # if we are not rethrow-ing then create the object to throw
171 $self = $self->new(@_) unless ref($self);
173 die $Error::THROWN = $self;
176 # syntactic sugar for
178 # die with Error( ... );
180 sub with {
181 my $self = shift;
182 local $Error::Depth = $Error::Depth + 1;
184 $self->new(@_);
187 # syntactic sugar for
189 # record Error( ... ) and return;
191 sub record {
192 my $self = shift;
193 local $Error::Depth = $Error::Depth + 1;
195 $self->new(@_);
198 # catch clause for
200 # try { ... } catch CLASS with { ... }
202 sub catch {
203 my $pkg = shift;
204 my $code = shift;
205 my $clauses = shift || {};
206 my $catch = $clauses->{'catch'} ||= [];
208 unshift @$catch, $pkg, $code;
210 $clauses;
213 # Object query methods
215 sub object {
216 my $self = shift;
217 exists $self->{'-object'} ? $self->{'-object'} : undef;
220 sub file {
221 my $self = shift;
222 exists $self->{'-file'} ? $self->{'-file'} : undef;
225 sub line {
226 my $self = shift;
227 exists $self->{'-line'} ? $self->{'-line'} : undef;
230 sub text {
231 my $self = shift;
232 exists $self->{'-text'} ? $self->{'-text'} : undef;
235 # overload methods
237 sub stringify {
238 my $self = shift;
239 defined $self->{'-text'} ? $self->{'-text'} : "Died";
242 sub value {
243 my $self = shift;
244 exists $self->{'-value'} ? $self->{'-value'} : undef;
247 package Error::Simple;
249 @Error::Simple::ISA = qw(Error);
251 sub new {
252 my $self = shift;
253 my $text = "" . shift;
254 my $value = shift;
255 my(@args) = ();
257 local $Error::Depth = $Error::Depth + 1;
259 @args = ( -file => $1, -line => $2)
260 if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s);
261 push(@args, '-value', 0 + $value)
262 if defined($value);
264 $self->SUPER::new(-text => $text, @args);
267 sub stringify {
268 my $self = shift;
269 my $text = $self->SUPER::stringify;
270 $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
271 unless($text =~ /\n$/s);
272 $text;
275 ##########################################################################
276 ##########################################################################
278 # Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
279 # Peter Seibel <peter@weblogic.com>
281 package Error::subs;
283 use Exporter ();
284 use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
286 @EXPORT_OK = qw(try with finally except otherwise);
287 %EXPORT_TAGS = (try => \@EXPORT_OK);
289 @ISA = qw(Exporter);
292 sub blessed {
293 my $item = shift;
294 local $@; # don't kill an outer $@
295 ref $item and eval { $item->can('can') };
299 sub run_clauses ($$$\@) {
300 my($clauses,$err,$wantarray,$result) = @_;
301 my $code = undef;
303 $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
305 CATCH: {
307 # catch
308 my $catch;
309 if(defined($catch = $clauses->{'catch'})) {
310 my $i = 0;
312 CATCHLOOP:
313 for( ; $i < @$catch ; $i += 2) {
314 my $pkg = $catch->[$i];
315 unless(defined $pkg) {
316 #except
317 splice(@$catch,$i,2,$catch->[$i+1]->());
318 $i -= 2;
319 next CATCHLOOP;
321 elsif(blessed($err) && $err->isa($pkg)) {
322 $code = $catch->[$i+1];
323 while(1) {
324 my $more = 0;
325 local($Error::THROWN);
326 my $ok = eval {
327 if($wantarray) {
328 @{$result} = $code->($err,\$more);
330 elsif(defined($wantarray)) {
331 @{$result} = ();
332 $result->[0] = $code->($err,\$more);
334 else {
335 $code->($err,\$more);
339 if( $ok ) {
340 next CATCHLOOP if $more;
341 undef $err;
343 else {
344 $err = defined($Error::THROWN)
345 ? $Error::THROWN : $@;
346 $err = $Error::ObjectifyCallback->({'text' =>$err})
347 unless ref($err);
349 last CATCH;
355 # otherwise
356 my $owise;
357 if(defined($owise = $clauses->{'otherwise'})) {
358 my $code = $clauses->{'otherwise'};
359 my $more = 0;
360 my $ok = eval {
361 if($wantarray) {
362 @{$result} = $code->($err,\$more);
364 elsif(defined($wantarray)) {
365 @{$result} = ();
366 $result->[0] = $code->($err,\$more);
368 else {
369 $code->($err,\$more);
373 if( $ok ) {
374 undef $err;
376 else {
377 $err = defined($Error::THROWN)
378 ? $Error::THROWN : $@;
380 $err = $Error::ObjectifyCallback->({'text' =>$err})
381 unless ref($err);
385 $err;
388 sub try (&;$) {
389 my $try = shift;
390 my $clauses = @_ ? shift : {};
391 my $ok = 0;
392 my $err = undef;
393 my @result = ();
395 unshift @Error::STACK, $clauses;
397 my $wantarray = wantarray();
399 do {
400 local $Error::THROWN = undef;
401 local $@ = undef;
403 $ok = eval {
404 if($wantarray) {
405 @result = $try->();
407 elsif(defined $wantarray) {
408 $result[0] = $try->();
410 else {
411 $try->();
416 $err = defined($Error::THROWN) ? $Error::THROWN : $@
417 unless $ok;
420 shift @Error::STACK;
422 $err = run_clauses($clauses,$err,wantarray,@result)
423 unless($ok);
425 $clauses->{'finally'}->()
426 if(defined($clauses->{'finally'}));
428 if (defined($err))
430 if (blessed($err) && $err->can('throw'))
432 throw $err;
434 else
436 die $err;
440 wantarray ? @result : $result[0];
443 # Each clause adds a sub to the list of clauses. The finally clause is
444 # always the last, and the otherwise clause is always added just before
445 # the finally clause.
447 # All clauses, except the finally clause, add a sub which takes one argument
448 # this argument will be the error being thrown. The sub will return a code ref
449 # if that clause can handle that error, otherwise undef is returned.
451 # The otherwise clause adds a sub which unconditionally returns the users
452 # code reference, this is why it is forced to be last.
454 # The catch clause is defined in Error.pm, as the syntax causes it to
455 # be called as a method
457 sub with (&;$) {
461 sub finally (&) {
462 my $code = shift;
463 my $clauses = { 'finally' => $code };
464 $clauses;
467 # The except clause is a block which returns a hashref or a list of
468 # key-value pairs, where the keys are the classes and the values are subs.
470 sub except (&;$) {
471 my $code = shift;
472 my $clauses = shift || {};
473 my $catch = $clauses->{'catch'} ||= [];
475 my $sub = sub {
476 my $ref;
477 my(@array) = $code->($_[0]);
478 if(@array == 1 && ref($array[0])) {
479 $ref = $array[0];
480 $ref = [ %$ref ]
481 if(UNIVERSAL::isa($ref,'HASH'));
483 else {
484 $ref = \@array;
486 @$ref
489 unshift @{$catch}, undef, $sub;
491 $clauses;
494 sub otherwise (&;$) {
495 my $code = shift;
496 my $clauses = shift || {};
498 if(exists $clauses->{'otherwise'}) {
499 require Carp;
500 Carp::croak("Multiple otherwise clauses");
503 $clauses->{'otherwise'} = $code;
505 $clauses;
509 __END__
511 =head1 NAME
513 Error - Error/exception handling in an OO-ish way
515 =head1 SYNOPSIS
517 use Error qw(:try);
519 throw Error::Simple( "A simple error");
521 sub xyz {
523 record Error::Simple("A simple error")
524 and return;
527 unlink($file) or throw Error::Simple("$file: $!",$!);
529 try {
530 do_some_stuff();
531 die "error!" if $condition;
532 throw Error::Simple -text => "Oops!" if $other_condition;
534 catch Error::IO with {
535 my $E = shift;
536 print STDERR "File ", $E->{'-file'}, " had a problem\n";
538 except {
539 my $E = shift;
540 my $general_handler=sub {send_message $E->{-description}};
541 return {
542 UserException1 => $general_handler,
543 UserException2 => $general_handler
546 otherwise {
547 print STDERR "Well I don't know what to say\n";
549 finally {
550 close_the_garage_door_already(); # Should be reliable
551 }; # Don't forget the trailing ; or you might be surprised
553 =head1 DESCRIPTION
555 The C<Error> package provides two interfaces. Firstly C<Error> provides
556 a procedural interface to exception handling. Secondly C<Error> is a
557 base class for errors/exceptions that can either be thrown, for
558 subsequent catch, or can simply be recorded.
560 Errors in the class C<Error> should not be thrown directly, but the
561 user should throw errors from a sub-class of C<Error>.
563 =head1 PROCEDURAL INTERFACE
565 C<Error> exports subroutines to perform exception handling. These will
566 be exported if the C<:try> tag is used in the C<use> line.
568 =over 4
570 =item try BLOCK CLAUSES
572 C<try> is the main subroutine called by the user. All other subroutines
573 exported are clauses to the try subroutine.
575 The BLOCK will be evaluated and, if no error is throw, try will return
576 the result of the block.
578 C<CLAUSES> are the subroutines below, which describe what to do in the
579 event of an error being thrown within BLOCK.
581 =item catch CLASS with BLOCK
583 This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
584 to be caught and handled by evaluating C<BLOCK>.
586 C<BLOCK> will be passed two arguments. The first will be the error
587 being thrown. The second is a reference to a scalar variable. If this
588 variable is set by the catch block then, on return from the catch
589 block, try will continue processing as if the catch block was never
590 found.
592 To propagate the error the catch block may call C<$err-E<gt>throw>
594 If the scalar reference by the second argument is not set, and the
595 error is not thrown. Then the current try block will return with the
596 result from the catch block.
598 =item except BLOCK
600 When C<try> is looking for a handler, if an except clause is found
601 C<BLOCK> is evaluated. The return value from this block should be a
602 HASHREF or a list of key-value pairs, where the keys are class names
603 and the values are CODE references for the handler of errors of that
604 type.
606 =item otherwise BLOCK
608 Catch any error by executing the code in C<BLOCK>
610 When evaluated C<BLOCK> will be passed one argument, which will be the
611 error being processed.
613 Only one otherwise block may be specified per try block
615 =item finally BLOCK
617 Execute the code in C<BLOCK> either after the code in the try block has
618 successfully completed, or if the try block throws an error then
619 C<BLOCK> will be executed after the handler has completed.
621 If the handler throws an error then the error will be caught, the
622 finally block will be executed and the error will be re-thrown.
624 Only one finally block may be specified per try block
626 =back
628 =head1 CLASS INTERFACE
630 =head2 CONSTRUCTORS
632 The C<Error> object is implemented as a HASH. This HASH is initialized
633 with the arguments that are passed to its constructor. The elements
634 that are used by, or are retrievable by the C<Error> class are listed
635 below, other classes may add to these.
637 -file
638 -line
639 -text
640 -value
641 -object
643 If C<-file> or C<-line> are not specified in the constructor arguments
644 then these will be initialized with the file name and line number where
645 the constructor was called from.
647 If the error is associated with an object then the object should be
648 passed as the C<-object> argument. This will allow the C<Error> package
649 to associate the error with the object.
651 The C<Error> package remembers the last error created, and also the
652 last error associated with a package. This could either be the last
653 error created by a sub in that package, or the last error which passed
654 an object blessed into that package as the C<-object> argument.
656 =over 4
658 =item throw ( [ ARGS ] )
660 Create a new C<Error> object and throw an error, which will be caught
661 by a surrounding C<try> block, if there is one. Otherwise it will cause
662 the program to exit.
664 C<throw> may also be called on an existing error to re-throw it.
666 =item with ( [ ARGS ] )
668 Create a new C<Error> object and returns it. This is defined for
669 syntactic sugar, eg
671 die with Some::Error ( ... );
673 =item record ( [ ARGS ] )
675 Create a new C<Error> object and returns it. This is defined for
676 syntactic sugar, eg
678 record Some::Error ( ... )
679 and return;
681 =back
683 =head2 STATIC METHODS
685 =over 4
687 =item prior ( [ PACKAGE ] )
689 Return the last error created, or the last error associated with
690 C<PACKAGE>
692 =item flush ( [ PACKAGE ] )
694 Flush the last error created, or the last error associated with
695 C<PACKAGE>.It is necessary to clear the error stack before exiting the
696 package or uncaught errors generated using C<record> will be reported.
698 $Error->flush;
700 =cut
702 =back
704 =head2 OBJECT METHODS
706 =over 4
708 =item stacktrace
710 If the variable C<$Error::Debug> was non-zero when the error was
711 created, then C<stacktrace> returns a string created by calling
712 C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
713 the text of the error appended with the filename and line number of
714 where the error was created, providing the text does not end with a
715 newline.
717 =item object
719 The object this error was associated with
721 =item file
723 The file where the constructor of this error was called from
725 =item line
727 The line where the constructor of this error was called from
729 =item text
731 The text of the error
733 =back
735 =head2 OVERLOAD METHODS
737 =over 4
739 =item stringify
741 A method that converts the object into a string. This method may simply
742 return the same as the C<text> method, or it may append more
743 information. For example the file name and line number.
745 By default this method returns the C<-text> argument that was passed to
746 the constructor, or the string C<"Died"> if none was given.
748 =item value
750 A method that will return a value that can be associated with the
751 error. For example if an error was created due to the failure of a
752 system call, then this may return the numeric value of C<$!> at the
753 time.
755 By default this method returns the C<-value> argument that was passed
756 to the constructor.
758 =back
760 =head1 PRE-DEFINED ERROR CLASSES
762 =over 4
764 =item Error::Simple
766 This class can be used to hold simple error strings and values. Its
767 constructor takes two arguments. The first is a text value, the second
768 is a numeric value. These values are what will be returned by the
769 overload methods.
771 If the text value ends with C<at file line 1> as $@ strings do, then
772 this information will be used to set the C<-file> and C<-line> arguments
773 of the error object.
775 This class is used internally if an eval'd block die's with an error
776 that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
778 =back
780 =head1 $Error::ObjectifyCallback
782 This variable holds a reference to a subroutine that converts errors that
783 are plain strings to objects. It is used by Error.pm to convert textual
784 errors to objects, and can be overridden by the user.
786 It accepts a single argument which is a hash reference to named parameters.
787 Currently the only named parameter passed is C<'text'> which is the text
788 of the error, but others may be available in the future.
790 For example the following code will cause Error.pm to throw objects of the
791 class MyError::Bar by default:
793 sub throw_MyError_Bar
795 my $args = shift;
796 my $err = MyError::Bar->new();
797 $err->{'MyBarText'} = $args->{'text'};
798 return $err;
802 local $Error::ObjectifyCallback = \&throw_MyError_Bar;
804 # Error handling here.
807 =head1 KNOWN BUGS
809 None, but that does not mean there are not any.
811 =head1 AUTHORS
813 Graham Barr <gbarr@pobox.com>
815 The code that inspired me to write this was originally written by
816 Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
817 <jglick@sig.bsh.com>.
819 =head1 MAINTAINER
821 Shlomi Fish <shlomif@iglu.org.il>
823 =head1 PAST MAINTAINERS
825 Arun Kumar U <u_arunkumar@yahoo.com>
827 =cut