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***
20
'bool' => sub { return 1; },
24
$Error::Depth = 0; # Depth to pass to caller()
25
$Error::Debug = 0; # Generate verbose stack traces
26
@Error::STACK = (); # Clause stack for try
27
$Error::THROWN = undef; # last error thrown, a workaround until die $ref works
29
my $LAST; # Last error created
30
my %ERROR; # Last error associated with package
32
# Exported subs are defined in Error::subs
36
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
37
Error::subs->import(@_);
40
# I really want to use last for the name of this method, but it is a keyword
41
# which prevent the syntax last Error
46
return $LAST unless @_;
49
return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
54
if($obj->isa('HASH')) {
55
$err = $obj->{'__Error__'}
56
if exists $obj->{'__Error__'};
58
elsif($obj->isa('GLOB')) {
59
$err = ${*$obj}{'__Error__'}
60
if exists ${*$obj}{'__Error__'};
66
# Return as much information as possible about where the error
67
# happened. The -stacktrace element only exists if $Error::DEBUG
68
# was set when the error was created
73
return $self->{'-stacktrace'}
74
if exists $self->{'-stacktrace'};
76
my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";
78
$text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
79
unless($text =~ /\n$/s);
84
# Allow error propagation, ie
86
# $ber->encode(...) or
87
# return Error->prior($ber)->associate($ldap);
93
return unless ref($obj);
95
if($obj->isa('HASH')) {
96
$obj->{'__Error__'} = $err;
98
elsif($obj->isa('GLOB')) {
99
${*$obj}{'__Error__'} = $err;
102
$ERROR{ ref($obj) } = $err;
109
my($pkg,$file,$line) = caller($Error::Depth);
118
$err->associate($err->{'-object'})
119
if(exists $err->{'-object'});
121
# To always create a stacktrace would be very inefficient, so
122
# we only do it if $Error::Debug is set
126
local $Carp::CarpLevel = $Error::Depth;
127
my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
128
my $trace = Carp::longmess($text);
129
# Remove try calls from the trace
130
$trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
131
$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;
132
$err->{'-stacktrace'} = $trace
135
$@ = $LAST = $ERROR{$pkg} = $err;
138
# Throw an error. this contains some very gory code.
142
local $Error::Depth = $Error::Depth + 1;
144
# if we are not rethrow-ing then create the object to throw
145
$self = $self->new(@_) unless ref($self);
147
die $Error::THROWN = $self;
150
# syntactic sugar for
152
# die with Error( ... );
156
local $Error::Depth = $Error::Depth + 1;
161
# syntactic sugar for
163
# record Error( ... ) and return;
167
local $Error::Depth = $Error::Depth + 1;
174
# try { ... } catch CLASS with { ... }
179
my $clauses = shift || {};
180
my $catch = $clauses->{'catch'} ||= [];
182
unshift @$catch, $pkg, $code;
187
# Object query methods
191
exists $self->{'-object'} ? $self->{'-object'} : undef;
196
exists $self->{'-file'} ? $self->{'-file'} : undef;
201
exists $self->{'-line'} ? $self->{'-line'} : undef;
206
exists $self->{'-text'} ? $self->{'-text'} : undef;
213
defined $self->{'-text'} ? $self->{'-text'} : "Died";
218
exists $self->{'-value'} ? $self->{'-value'} : undef;
221
package Error::Simple;
223
@Error::Simple::ISA = qw(Error);
227
my $text = "" . shift;
231
local $Error::Depth = $Error::Depth + 1;
233
@args = ( -file => $1, -line => $2)
234
if($text =~ s/ at (\S+) line (\d+)(\.\n)?$//s);
236
push(@args, '-value', 0 + $value)
239
$self->SUPER::new(-text => $text, @args);
244
my $text = $self->SUPER::stringify;
245
$text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
246
unless($text =~ /\n$/s);
250
##########################################################################
251
##########################################################################
253
# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
254
# Peter Seibel <peter@weblogic.com>
259
use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);
261
@EXPORT_OK = qw(try with finally except otherwise);
262
%EXPORT_TAGS = (try => \@EXPORT_OK);
266
sub run_clauses ($$$\@) {
267
my($clauses,$err,$wantarray,$result) = @_;
270
$err = new Error::Simple($err) unless ref($err);
276
if(defined($catch = $clauses->{'catch'})) {
280
for( ; $i < @$catch ; $i += 2) {
281
my $pkg = $catch->[$i];
282
unless(defined $pkg) {
284
splice(@$catch,$i,2,$catch->[$i+1]->());
288
elsif($err->isa($pkg)) {
289
$code = $catch->[$i+1];
292
local($Error::THROWN);
295
@{$result} = $code->($err,\$more);
297
elsif(defined($wantarray)) {
299
$result->[0] = $code->($err,\$more);
302
$code->($err,\$more);
307
next CATCHLOOP if $more;
311
$err = defined($Error::THROWN)
312
? $Error::THROWN : $@;
313
$err = new Error::Simple($err)
324
if(defined($owise = $clauses->{'otherwise'})) {
325
my $code = $clauses->{'otherwise'};
329
@{$result} = $code->($err,\$more);
331
elsif(defined($wantarray)) {
333
$result->[0] = $code->($err,\$more);
336
$code->($err,\$more);
344
$err = defined($Error::THROWN)
345
? $Error::THROWN : $@;
346
$err = new Error::Simple($err)
356
my $clauses = @_ ? shift : {};
361
unshift @Error::STACK, $clauses;
363
my $wantarray = wantarray();
366
local $Error::THROWN = undef;
372
elsif(defined $wantarray) {
373
$result[0] = $try->();
381
$err = defined($Error::THROWN) ? $Error::THROWN : $@
387
$err = run_clauses($clauses,$err,wantarray,@result)
390
$clauses->{'finally'}->()
391
if(defined($clauses->{'finally'}));
393
throw $err if defined($err);
395
wantarray ? @result : $result[0];
398
# Each clause adds a sub to the list of clauses. The finally clause is
399
# always the last, and the otherwise clause is always added just before
400
# the finally clause.
402
# All clauses, except the finally clause, add a sub which takes one argument
403
# this argument will be the error being thrown. The sub will return a code ref
404
# if that clause can handle that error, otherwise undef is returned.
406
# The otherwise clause adds a sub which unconditionally returns the users
407
# code reference, this is why it is forced to be last.
409
# The catch clause is defined in Error.pm, as the syntax causes it to
410
# be called as a method
418
my $clauses = { 'finally' => $code };
422
# The except clause is a block which returns a hashref or a list of
423
# key-value pairs, where the keys are the classes and the values are subs.
427
my $clauses = shift || {};
428
my $catch = $clauses->{'catch'} ||= [];
432
my(@array) = $code->($_[0]);
433
if(@array == 1 && ref($array[0])) {
436
if(UNIVERSAL::isa($ref,'HASH'));
444
unshift @{$catch}, undef, $sub;
449
sub otherwise (&;$) {
451
my $clauses = shift || {};
453
if(exists $clauses->{'otherwise'}) {
455
Carp::croak("Multiple otherwise clauses");
458
$clauses->{'otherwise'} = $code;
468
Error - Error/exception handling in an OO-ish way
474
throw Error::Simple( "A simple error");
478
record Error::Simple("A simple error")
482
unlink($file) or throw Error::Simple("$file: $!",$!);
486
die "error!" if $condition;
487
throw Error::Simple -text => "Oops!" if $other_condition;
489
catch Error::IO with {
491
print STDERR "File ", $E->{'-file'}, " had a problem\n";
495
my $general_handler=sub {send_message $E->{-description}};
497
UserException1 => $general_handler,
498
UserException2 => $general_handler
502
print STDERR "Well I don't know what to say\n";
505
close_the_garage_door_already(); # Should be reliable
506
}; # Don't forget the trailing ; or you might be surprised
510
The C<Error> package provides two interfaces. Firstly C<Error> provides
511
a procedural interface to exception handling. Secondly C<Error> is a
512
base class for errors/exceptions that can either be thrown, for
513
subsequent catch, or can simply be recorded.
515
Errors in the class C<Error> should not be thrown directly, but the
516
user should throw errors from a sub-class of C<Error>.
518
=head1 PROCEDURAL INTERFACE
520
C<Error> exports subroutines to perform exception handling. These will
521
be exported if the C<:try> tag is used in the C<use> line.
525
=item try BLOCK CLAUSES
527
C<try> is the main subroutine called by the user. All other subroutines
528
exported are clauses to the try subroutine.
530
The BLOCK will be evaluated and, if no error is throw, try will return
531
the result of the block.
533
C<CLAUSES> are the subroutines below, which describe what to do in the
534
event of an error being thrown within BLOCK.
536
=item catch CLASS with BLOCK
538
This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
539
to be caught and handled by evaluating C<BLOCK>.
541
C<BLOCK> will be passed two arguments. The first will be the error
542
being thrown. The second is a reference to a scalar variable. If this
543
variable is set by the catch block then, on return from the catch
544
block, try will continue processing as if the catch block was never
547
To propagate the error the catch block may call C<$err-E<gt>throw>
549
If the scalar reference by the second argument is not set, and the
550
error is not thrown. Then the current try block will return with the
551
result from the catch block.
555
When C<try> is looking for a handler, if an except clause is found
556
C<BLOCK> is evaluated. The return value from this block should be a
557
HASHREF or a list of key-value pairs, where the keys are class names
558
and the values are CODE references for the handler of errors of that
561
=item otherwise BLOCK
563
Catch any error by executing the code in C<BLOCK>
565
When evaluated C<BLOCK> will be passed one argument, which will be the
566
error being processed.
568
Only one otherwise block may be specified per try block
572
Execute the code in C<BLOCK> either after the code in the try block has
573
successfully completed, or if the try block throws an error then
574
C<BLOCK> will be executed after the handler has completed.
576
If the handler throws an error then the error will be caught, the
577
finally block will be executed and the error will be re-thrown.
579
Only one finally block may be specified per try block
583
=head1 CLASS INTERFACE
587
The C<Error> object is implemented as a HASH. This HASH is initialized
588
with the arguments that are passed to it's constructor. The elements
589
that are used by, or are retrievable by the C<Error> class are listed
590
below, other classes may add to these.
598
If C<-file> or C<-line> are not specified in the constructor arguments
599
then these will be initialized with the file name and line number where
600
the constructor was called from.
602
If the error is associated with an object then the object should be
603
passed as the C<-object> argument. This will allow the C<Error> package
604
to associate the error with the object.
606
The C<Error> package remembers the last error created, and also the
607
last error associated with a package. This could either be the last
608
error created by a sub in that package, or the last error which passed
609
an object blessed into that package as the C<-object> argument.
613
=item throw ( [ ARGS ] )
615
Create a new C<Error> object and throw an error, which will be caught
616
by a surrounding C<try> block, if there is one. Otherwise it will cause
619
C<throw> may also be called on an existing error to re-throw it.
621
=item with ( [ ARGS ] )
623
Create a new C<Error> object and returns it. This is defined for
626
die with Some::Error ( ... );
628
=item record ( [ ARGS ] )
630
Create a new C<Error> object and returns it. This is defined for
633
record Some::Error ( ... )
638
=head2 STATIC METHODS
642
=item prior ( [ PACKAGE ] )
644
Return the last error created, or the last error associated with
649
=head2 OBJECT METHODS
655
If the variable C<$Error::Debug> was non-zero when the error was
656
created, then C<stacktrace> returns a string created by calling
657
C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
658
the text of the error appended with the filename and line number of
659
where the error was created, providing the text does not end with a
664
The object this error was associated with
668
The file where the constructor of this error was called from
672
The line where the constructor of this error was called from
676
The text of the error
680
=head2 OVERLOAD METHODS
686
A method that converts the object into a string. This method may simply
687
return the same as the C<text> method, or it may append more
688
information. For example the file name and line number.
690
By default this method returns the C<-text> argument that was passed to
691
the constructor, or the string C<"Died"> if none was given.
695
A method that will return a value that can be associated with the
696
error. For example if an error was created due to the failure of a
697
system call, then this may return the numeric value of C<$!> at the
700
By default this method returns the C<-value> argument that was passed
705
=head1 PRE-DEFINED ERROR CLASSES
711
This class can be used to hold simple error strings and values. It's
712
constructor takes two arguments. The first is a text value, the second
713
is a numeric value. These values are what will be returned by the
716
If the text value ends with C<at file line 1> as $@ strings do, then
717
this infomation will be used to set the C<-file> and C<-line> arguments
720
This class is used internally if an eval'd block die's with an error
721
that is a plain string.
727
None, but that does not mean there are not any.
731
Graham Barr, gbarr@pobox.com
733
The code that inspired me to write this was originally written by
734
Peter Seibel E<lt>peter@weblogic.comE<gt> and adapted by Jesse Glick
735
E<lt>jglick@sig.bsh.comE<gt>.
739
Arun Kumar U, u_arunkumar@yahoo.com
added
removed
t/lib/Error.pm
