blob: ebd07498a22ec598449211e8a26c0b63689633ff [file] [log] [blame]
Petr Baudis5c4082f2006-06-24 04:34:40 +02001# 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
12package Error;
13
14use strict;
15use vars qw($VERSION);
16use 5.004;
17
18$VERSION = "0.15009";
19
20use overload (
21 '""' => 'stringify',
22 '0+' => 'value',
23 'bool' => sub { return 1; },
24 'fallback' => 1
25);
26
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
31
32my $LAST; # Last error created
33my %ERROR; # Last error associated with package
34
35sub throw_Error_Simple
36{
37 my $args = shift;
38 return Error::Simple->new($args->{'text'});
39}
40
41$Error::ObjectifyCallback = \&throw_Error_Simple;
42
43
44# Exported subs are defined in Error::subs
45
46use Scalar::Util ();
47
48sub import {
49 shift;
50 local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
51 Error::subs->import(@_);
52}
53
54# I really want to use last for the name of this method, but it is a keyword
55# which prevent the syntax last Error
56
57sub prior {
58 shift; # ignore
59
60 return $LAST unless @_;
61
62 my $pkg = shift;
63 return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
64 unless ref($pkg);
65
66 my $obj = $pkg;
67 my $err = undef;
68 if($obj->isa('HASH')) {
69 $err = $obj->{'__Error__'}
70 if exists $obj->{'__Error__'};
71 }
72 elsif($obj->isa('GLOB')) {
73 $err = ${*$obj}{'__Error__'}
74 if exists ${*$obj}{'__Error__'};
75 }
76
77 $err;
78}
79
80sub flush {
81 shift; #ignore
82
83 unless (@_) {
84 $LAST = undef;
85 return;
86 }
87
88 my $pkg = shift;
89 return unless ref($pkg);
90
91 undef $ERROR{$pkg} if defined $ERROR{$pkg};
92}
93
94# Return as much information as possible about where the error
95# happened. The -stacktrace element only exists if $Error::DEBUG
96# was set when the error was created
97
98sub stacktrace {
99 my $self = shift;
100
101 return $self->{'-stacktrace'}
102 if exists $self->{'-stacktrace'};
103
104 my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
105
106 $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
107 unless($text =~ /\n$/s);
108
109 $text;
110}
111
112# Allow error propagation, ie
113#
114# $ber->encode(...) or
115# return Error->prior($ber)->associate($ldap);
116
117sub associate {
118 my $err = shift;
119 my $obj = shift;
120
121 return unless ref($obj);
122
123 if($obj->isa('HASH')) {
124 $obj->{'__Error__'} = $err;
125 }
126 elsif($obj->isa('GLOB')) {
127 ${*$obj}{'__Error__'} = $err;
128 }
129 $obj = ref($obj);
130 $ERROR{ ref($obj) } = $err;
131
132 return;
133}
134
135sub new {
136 my $self = shift;
137 my($pkg,$file,$line) = caller($Error::Depth);
138
139 my $err = bless {
140 '-package' => $pkg,
141 '-file' => $file,
142 '-line' => $line,
143 @_
144 }, $self;
145
146 $err->associate($err->{'-object'})
147 if(exists $err->{'-object'});
148
149 # To always create a stacktrace would be very inefficient, so
150 # we only do it if $Error::Debug is set
151
152 if($Error::Debug) {
153 require Carp;
154 local $Carp::CarpLevel = $Error::Depth;
155 my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
156 my $trace = Carp::longmess($text);
157 # Remove try calls from the trace
158 $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
159 $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;
160 $err->{'-stacktrace'} = $trace
161 }
162
163 $@ = $LAST = $ERROR{$pkg} = $err;
164}
165
166# Throw an error. this contains some very gory code.
167
168sub throw {
169 my $self = shift;
170 local $Error::Depth = $Error::Depth + 1;
171
172 # if we are not rethrow-ing then create the object to throw
173 $self = $self->new(@_) unless ref($self);
174
175 die $Error::THROWN = $self;
176}
177
178# syntactic sugar for
179#
180# die with Error( ... );
181
182sub with {
183 my $self = shift;
184 local $Error::Depth = $Error::Depth + 1;
185
186 $self->new(@_);
187}
188
189# syntactic sugar for
190#
191# record Error( ... ) and return;
192
193sub record {
194 my $self = shift;
195 local $Error::Depth = $Error::Depth + 1;
196
197 $self->new(@_);
198}
199
200# catch clause for
201#
202# try { ... } catch CLASS with { ... }
203
204sub catch {
205 my $pkg = shift;
206 my $code = shift;
207 my $clauses = shift || {};
208 my $catch = $clauses->{'catch'} ||= [];
209
210 unshift @$catch, $pkg, $code;
211
212 $clauses;
213}
214
215# Object query methods
216
217sub object {
218 my $self = shift;
219 exists $self->{'-object'} ? $self->{'-object'} : undef;
220}
221
222sub file {
223 my $self = shift;
224 exists $self->{'-file'} ? $self->{'-file'} : undef;
225}
226
227sub line {
228 my $self = shift;
229 exists $self->{'-line'} ? $self->{'-line'} : undef;
230}
231
232sub text {
233 my $self = shift;
234 exists $self->{'-text'} ? $self->{'-text'} : undef;
235}
236
237# overload methods
238
239sub stringify {
240 my $self = shift;
241 defined $self->{'-text'} ? $self->{'-text'} : "Died";
242}
243
244sub value {
245 my $self = shift;
246 exists $self->{'-value'} ? $self->{'-value'} : undef;
247}
248
249package Error::Simple;
250
251@Error::Simple::ISA = qw(Error);
252
253sub new {
254 my $self = shift;
255 my $text = "" . shift;
256 my $value = shift;
257 my(@args) = ();
258
259 local $Error::Depth = $Error::Depth + 1;
260
261 @args = ( -file => $1, -line => $2)
262 if($text =~ s/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\d+)?\.?\n?$//s);
263 push(@args, '-value', 0 + $value)
264 if defined($value);
265
266 $self->SUPER::new(-text => $text, @args);
267}
268
269sub stringify {
270 my $self = shift;
271 my $text = $self->SUPER::stringify;
272 $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
273 unless($text =~ /\n$/s);
274 $text;
275}
276
277##########################################################################
278##########################################################################
279
280# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
281# Peter Seibel <peter@weblogic.com>
282
283package Error::subs;
284
285use Exporter ();
286use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
287
288@EXPORT_OK = qw(try with finally except otherwise);
289%EXPORT_TAGS = (try => \@EXPORT_OK);
290
291@ISA = qw(Exporter);
292
293sub run_clauses ($$$\@) {
294 my($clauses,$err,$wantarray,$result) = @_;
295 my $code = undef;
296
297 $err = $Error::ObjectifyCallback->({'text' =>$err}) unless ref($err);
298
299 CATCH: {
300
301 # catch
302 my $catch;
303 if(defined($catch = $clauses->{'catch'})) {
304 my $i = 0;
305
306 CATCHLOOP:
307 for( ; $i < @$catch ; $i += 2) {
308 my $pkg = $catch->[$i];
309 unless(defined $pkg) {
310 #except
311 splice(@$catch,$i,2,$catch->[$i+1]->());
312 $i -= 2;
313 next CATCHLOOP;
314 }
315 elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) {
316 $code = $catch->[$i+1];
317 while(1) {
318 my $more = 0;
319 local($Error::THROWN);
320 my $ok = eval {
321 if($wantarray) {
322 @{$result} = $code->($err,\$more);
323 }
324 elsif(defined($wantarray)) {
325 @{$result} = ();
326 $result->[0] = $code->($err,\$more);
327 }
328 else {
329 $code->($err,\$more);
330 }
331 1;
332 };
333 if( $ok ) {
334 next CATCHLOOP if $more;
335 undef $err;
336 }
337 else {
338 $err = defined($Error::THROWN)
339 ? $Error::THROWN : $@;
340 $err = $Error::ObjectifyCallback->({'text' =>$err})
341 unless ref($err);
342 }
343 last CATCH;
344 };
345 }
346 }
347 }
348
349 # otherwise
350 my $owise;
351 if(defined($owise = $clauses->{'otherwise'})) {
352 my $code = $clauses->{'otherwise'};
353 my $more = 0;
354 my $ok = eval {
355 if($wantarray) {
356 @{$result} = $code->($err,\$more);
357 }
358 elsif(defined($wantarray)) {
359 @{$result} = ();
360 $result->[0] = $code->($err,\$more);
361 }
362 else {
363 $code->($err,\$more);
364 }
365 1;
366 };
367 if( $ok ) {
368 undef $err;
369 }
370 else {
371 $err = defined($Error::THROWN)
372 ? $Error::THROWN : $@;
373
374 $err = $Error::ObjectifyCallback->({'text' =>$err})
375 unless ref($err);
376 }
377 }
378 }
379 $err;
380}
381
382sub try (&;$) {
383 my $try = shift;
384 my $clauses = @_ ? shift : {};
385 my $ok = 0;
386 my $err = undef;
387 my @result = ();
388
389 unshift @Error::STACK, $clauses;
390
391 my $wantarray = wantarray();
392
393 do {
394 local $Error::THROWN = undef;
395 local $@ = undef;
396
397 $ok = eval {
398 if($wantarray) {
399 @result = $try->();
400 }
401 elsif(defined $wantarray) {
402 $result[0] = $try->();
403 }
404 else {
405 $try->();
406 }
407 1;
408 };
409
410 $err = defined($Error::THROWN) ? $Error::THROWN : $@
411 unless $ok;
412 };
413
414 shift @Error::STACK;
415
416 $err = run_clauses($clauses,$err,wantarray,@result)
417 unless($ok);
418
419 $clauses->{'finally'}->()
420 if(defined($clauses->{'finally'}));
421
422 if (defined($err))
423 {
424 if (Scalar::Util::blessed($err) && $err->can('throw'))
425 {
426 throw $err;
427 }
428 else
429 {
430 die $err;
431 }
432 }
433
434 wantarray ? @result : $result[0];
435}
436
437# Each clause adds a sub to the list of clauses. The finally clause is
438# always the last, and the otherwise clause is always added just before
439# the finally clause.
440#
441# All clauses, except the finally clause, add a sub which takes one argument
442# this argument will be the error being thrown. The sub will return a code ref
443# if that clause can handle that error, otherwise undef is returned.
444#
445# The otherwise clause adds a sub which unconditionally returns the users
446# code reference, this is why it is forced to be last.
447#
448# The catch clause is defined in Error.pm, as the syntax causes it to
449# be called as a method
450
451sub with (&;$) {
452 @_
453}
454
455sub finally (&) {
456 my $code = shift;
457 my $clauses = { 'finally' => $code };
458 $clauses;
459}
460
461# The except clause is a block which returns a hashref or a list of
462# key-value pairs, where the keys are the classes and the values are subs.
463
464sub except (&;$) {
465 my $code = shift;
466 my $clauses = shift || {};
467 my $catch = $clauses->{'catch'} ||= [];
468
469 my $sub = sub {
470 my $ref;
471 my(@array) = $code->($_[0]);
472 if(@array == 1 && ref($array[0])) {
473 $ref = $array[0];
474 $ref = [ %$ref ]
475 if(UNIVERSAL::isa($ref,'HASH'));
476 }
477 else {
478 $ref = \@array;
479 }
480 @$ref
481 };
482
483 unshift @{$catch}, undef, $sub;
484
485 $clauses;
486}
487
488sub otherwise (&;$) {
489 my $code = shift;
490 my $clauses = shift || {};
491
492 if(exists $clauses->{'otherwise'}) {
493 require Carp;
494 Carp::croak("Multiple otherwise clauses");
495 }
496
497 $clauses->{'otherwise'} = $code;
498
499 $clauses;
500}
501
5021;
503__END__
504
505=head1 NAME
506
507Error - Error/exception handling in an OO-ish way
508
509=head1 SYNOPSIS
510
511 use Error qw(:try);
512
513 throw Error::Simple( "A simple error");
514
515 sub xyz {
516 ...
517 record Error::Simple("A simple error")
518 and return;
519 }
520
521 unlink($file) or throw Error::Simple("$file: $!",$!);
522
523 try {
524 do_some_stuff();
525 die "error!" if $condition;
526 throw Error::Simple -text => "Oops!" if $other_condition;
527 }
528 catch Error::IO with {
529 my $E = shift;
530 print STDERR "File ", $E->{'-file'}, " had a problem\n";
531 }
532 except {
533 my $E = shift;
534 my $general_handler=sub {send_message $E->{-description}};
535 return {
536 UserException1 => $general_handler,
537 UserException2 => $general_handler
538 };
539 }
540 otherwise {
541 print STDERR "Well I don't know what to say\n";
542 }
543 finally {
544 close_the_garage_door_already(); # Should be reliable
545 }; # Don't forget the trailing ; or you might be surprised
546
547=head1 DESCRIPTION
548
549The C<Error> package provides two interfaces. Firstly C<Error> provides
550a procedural interface to exception handling. Secondly C<Error> is a
551base class for errors/exceptions that can either be thrown, for
552subsequent catch, or can simply be recorded.
553
554Errors in the class C<Error> should not be thrown directly, but the
555user should throw errors from a sub-class of C<Error>.
556
557=head1 PROCEDURAL INTERFACE
558
559C<Error> exports subroutines to perform exception handling. These will
560be exported if the C<:try> tag is used in the C<use> line.
561
562=over 4
563
564=item try BLOCK CLAUSES
565
566C<try> is the main subroutine called by the user. All other subroutines
567exported are clauses to the try subroutine.
568
569The BLOCK will be evaluated and, if no error is throw, try will return
570the result of the block.
571
572C<CLAUSES> are the subroutines below, which describe what to do in the
573event of an error being thrown within BLOCK.
574
575=item catch CLASS with BLOCK
576
577This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
578to be caught and handled by evaluating C<BLOCK>.
579
580C<BLOCK> will be passed two arguments. The first will be the error
581being thrown. The second is a reference to a scalar variable. If this
582variable is set by the catch block then, on return from the catch
583block, try will continue processing as if the catch block was never
584found.
585
586To propagate the error the catch block may call C<$err-E<gt>throw>
587
588If the scalar reference by the second argument is not set, and the
589error is not thrown. Then the current try block will return with the
590result from the catch block.
591
592=item except BLOCK
593
594When C<try> is looking for a handler, if an except clause is found
595C<BLOCK> is evaluated. The return value from this block should be a
596HASHREF or a list of key-value pairs, where the keys are class names
597and the values are CODE references for the handler of errors of that
598type.
599
600=item otherwise BLOCK
601
602Catch any error by executing the code in C<BLOCK>
603
604When evaluated C<BLOCK> will be passed one argument, which will be the
605error being processed.
606
607Only one otherwise block may be specified per try block
608
609=item finally BLOCK
610
611Execute the code in C<BLOCK> either after the code in the try block has
612successfully completed, or if the try block throws an error then
613C<BLOCK> will be executed after the handler has completed.
614
615If the handler throws an error then the error will be caught, the
616finally block will be executed and the error will be re-thrown.
617
618Only one finally block may be specified per try block
619
620=back
621
622=head1 CLASS INTERFACE
623
624=head2 CONSTRUCTORS
625
626The C<Error> object is implemented as a HASH. This HASH is initialized
627with the arguments that are passed to it's constructor. The elements
628that are used by, or are retrievable by the C<Error> class are listed
629below, other classes may add to these.
630
631 -file
632 -line
633 -text
634 -value
635 -object
636
637If C<-file> or C<-line> are not specified in the constructor arguments
638then these will be initialized with the file name and line number where
639the constructor was called from.
640
641If the error is associated with an object then the object should be
642passed as the C<-object> argument. This will allow the C<Error> package
643to associate the error with the object.
644
645The C<Error> package remembers the last error created, and also the
646last error associated with a package. This could either be the last
647error created by a sub in that package, or the last error which passed
648an object blessed into that package as the C<-object> argument.
649
650=over 4
651
652=item throw ( [ ARGS ] )
653
654Create a new C<Error> object and throw an error, which will be caught
655by a surrounding C<try> block, if there is one. Otherwise it will cause
656the program to exit.
657
658C<throw> may also be called on an existing error to re-throw it.
659
660=item with ( [ ARGS ] )
661
662Create a new C<Error> object and returns it. This is defined for
663syntactic sugar, eg
664
665 die with Some::Error ( ... );
666
667=item record ( [ ARGS ] )
668
669Create a new C<Error> object and returns it. This is defined for
670syntactic sugar, eg
671
672 record Some::Error ( ... )
673 and return;
674
675=back
676
677=head2 STATIC METHODS
678
679=over 4
680
681=item prior ( [ PACKAGE ] )
682
683Return the last error created, or the last error associated with
684C<PACKAGE>
685
686=item flush ( [ PACKAGE ] )
687
688Flush the last error created, or the last error associated with
689C<PACKAGE>.It is necessary to clear the error stack before exiting the
690package or uncaught errors generated using C<record> will be reported.
691
692 $Error->flush;
693
694=cut
695
696=back
697
698=head2 OBJECT METHODS
699
700=over 4
701
702=item stacktrace
703
704If the variable C<$Error::Debug> was non-zero when the error was
705created, then C<stacktrace> returns a string created by calling
706C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
707the text of the error appended with the filename and line number of
708where the error was created, providing the text does not end with a
709newline.
710
711=item object
712
713The object this error was associated with
714
715=item file
716
717The file where the constructor of this error was called from
718
719=item line
720
721The line where the constructor of this error was called from
722
723=item text
724
725The text of the error
726
727=back
728
729=head2 OVERLOAD METHODS
730
731=over 4
732
733=item stringify
734
735A method that converts the object into a string. This method may simply
736return the same as the C<text> method, or it may append more
737information. For example the file name and line number.
738
739By default this method returns the C<-text> argument that was passed to
740the constructor, or the string C<"Died"> if none was given.
741
742=item value
743
744A method that will return a value that can be associated with the
745error. For example if an error was created due to the failure of a
746system call, then this may return the numeric value of C<$!> at the
747time.
748
749By default this method returns the C<-value> argument that was passed
750to the constructor.
751
752=back
753
754=head1 PRE-DEFINED ERROR CLASSES
755
756=over 4
757
758=item Error::Simple
759
760This class can be used to hold simple error strings and values. It's
761constructor takes two arguments. The first is a text value, the second
762is a numeric value. These values are what will be returned by the
763overload methods.
764
765If the text value ends with C<at file line 1> as $@ strings do, then
766this infomation will be used to set the C<-file> and C<-line> arguments
767of the error object.
768
769This class is used internally if an eval'd block die's with an error
770that is a plain string. (Unless C<$Error::ObjectifyCallback> is modified)
771
772=back
773
774=head1 $Error::ObjectifyCallback
775
776This variable holds a reference to a subroutine that converts errors that
777are plain strings to objects. It is used by Error.pm to convert textual
778errors to objects, and can be overrided by the user.
779
780It accepts a single argument which is a hash reference to named parameters.
781Currently the only named parameter passed is C<'text'> which is the text
782of the error, but others may be available in the future.
783
784For example the following code will cause Error.pm to throw objects of the
785class MyError::Bar by default:
786
787 sub throw_MyError_Bar
788 {
789 my $args = shift;
790 my $err = MyError::Bar->new();
791 $err->{'MyBarText'} = $args->{'text'};
792 return $err;
793 }
794
795 {
796 local $Error::ObjectifyCallback = \&throw_MyError_Bar;
797
798 # Error handling here.
799 }
800
801=head1 KNOWN BUGS
802
803None, but that does not mean there are not any.
804
805=head1 AUTHORS
806
807Graham Barr <gbarr@pobox.com>
808
809The code that inspired me to write this was originally written by
810Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
811<jglick@sig.bsh.com>.
812
813=head1 MAINTAINER
814
815Shlomi Fish <shlomif@iglu.org.il>
816
817=head1 PAST MAINTAINERS
818
819Arun Kumar U <u_arunkumar@yahoo.com>
820
821=cut