manakai/lib/Error.pm

# Error.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@ti.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Based on my original Error.pm, and Exceptions.pm by Peter Seibel
# <peter@weblogic.com> and adapted by Jesse Glick <jglick@sig.bsh.com>.
#
# but modified ***significantly***

package Error;

use strict;
use vars qw($VERSION);
use 5.004;

$VERSION = "0.15"; 

use overload (
        '""'       =>   'stringify',
        '0+'       =>   'value',
        'bool'     =>   sub { return 1; },
        'fallback' =>   1
);

$Error::Depth = 0;      # Depth to pass to caller()
$Error::Debug = 0;      # Generate verbose stack traces
@Error::STACK = ();     # Clause stack for try
$Error::THROWN = undef; # last error thrown, a workaround until die $ref works

my $LAST;               # Last error created
my %ERROR;              # Last error associated with package

# Exported subs are defined in Error::subs

sub import {
    shift;
    local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
    Error::subs->import(@_);
}

# I really want to use last for the name of this method, but it is a keyword
# which prevent the syntax  last Error

sub prior {
    shift; # ignore

    return $LAST unless @_;

    my $pkg = shift;
    return exists $ERROR{$pkg} ? $ERROR{$pkg} : undef
        unless ref($pkg);

    my $obj = $pkg;
    my $err = undef;
    if($obj->isa('HASH')) {
        $err = $obj->{'__Error__'}
            if exists $obj->{'__Error__'};
    }
    elsif($obj->isa('GLOB')) {
        $err = ${*$obj}{'__Error__'}
            if exists ${*$obj}{'__Error__'};
    }

    $err;
}

# Return as much information as possible about where the error
# happened. The -stacktrace element only exists if $Error::DEBUG
# was set when the error was created

sub stacktrace {
    my $self = shift;

    return $self->{'-stacktrace'}
        if exists $self->{'-stacktrace'};

    my $text = exists $self->{'-text'} ? $self->{'-text'} : "Died";

    $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
        unless($text =~ /\n$/s);

    $text;
}

# Allow error propagation, ie
#
# $ber->encode(...) or
#    return Error->prior($ber)->associate($ldap);

sub associate {
    my $err = shift;
    my $obj = shift;

    return unless ref($obj);

    if($obj->isa('HASH')) {
        $obj->{'__Error__'} = $err;
    }
    elsif($obj->isa('GLOB')) {
        ${*$obj}{'__Error__'} = $err;
    }
    $obj = ref($obj);
    $ERROR{ ref($obj) } = $err;

    return;
}

sub new {
    my $self = shift;
    my($pkg,$file,$line) = caller($Error::Depth);

    my $err = bless {
        '-package' => $pkg,
        '-file'    => $file,
        '-line'    => $line,
        @_
    }, $self;

    $err->associate($err->{'-object'})
        if(exists $err->{'-object'});

    # To always create a stacktrace would be very inefficient, so
    # we only do it if $Error::Debug is set

    if($Error::Debug) {
        require Carp;
        local $Carp::CarpLevel = $Error::Depth;
        my $text = defined($err->{'-text'}) ? $err->{'-text'} : "Error";
        my $trace = Carp::longmess($text);
        # Remove try calls from the trace
        $trace =~ s/(\n\s+\S+__ANON__[^\n]+)?\n\s+eval[^\n]+\n\s+Error::subs::try[^\n]+(?=\n)//sog;
        $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;
        $err->{'-stacktrace'} = $trace
    }

    $@ = $LAST = $ERROR{$pkg} = $err;
}

# Throw an error. this contains some very gory code.

sub throw {
    my $self = shift;
    local $Error::Depth = $Error::Depth + 1;

    # if we are not rethrow-ing then create the object to throw
    $self = $self->new(@_) unless ref($self);
    
    die $Error::THROWN = $self;
}

# syntactic sugar for
#
#    die with Error( ... );

sub with {
    my $self = shift;
    local $Error::Depth = $Error::Depth + 1;

    $self->new(@_);
}

# syntactic sugar for
#
#    record Error( ... ) and return;

sub record {
    my $self = shift;
    local $Error::Depth = $Error::Depth + 1;

    $self->new(@_);
}

# catch clause for
#
# try { ... } catch CLASS with { ... }

sub catch {
    my $pkg = shift;
    my $code = shift;
    my $clauses = shift || {};
    my $catch = $clauses->{'catch'} ||= [];

    unshift @$catch,  $pkg, $code;

    $clauses;
}

# Object query methods

sub object {
    my $self = shift;
    exists $self->{'-object'} ? $self->{'-object'} : undef;
}

sub file {
    my $self = shift;
    exists $self->{'-file'} ? $self->{'-file'} : undef;
}

sub line {
    my $self = shift;
    exists $self->{'-line'} ? $self->{'-line'} : undef;
}

sub text {
    my $self = shift;
    exists $self->{'-text'} ? $self->{'-text'} : undef;
}

# overload methods

sub stringify {
    my $self = shift;
    defined $self->{'-text'} ? $self->{'-text'} : "Died";
}

sub value {
    my $self = shift;
    exists $self->{'-value'} ? $self->{'-value'} : undef;
}

package Error::Simple;

@Error::Simple::ISA = qw(Error);

sub new {
    my $self  = shift;
    my $text  = "" . shift;
    my $value = shift;
    my(@args) = ();

    local $Error::Depth = $Error::Depth + 1;

    @args = ( -file => $1, -line => $2)
        if($text =~ s/ at (\S+) line (\d+)(\.\n)?$//s);

    push(@args, '-value', 0 + $value)
        if defined($value);

    $self->SUPER::new(-text => $text, @args);
}

sub stringify {
    my $self = shift;
    my $text = $self->SUPER::stringify;
    $text .= sprintf(" at %s line %d.\n", $self->file, $self->line)
        unless($text =~ /\n$/s);
    $text;
}

##########################################################################
##########################################################################

# Inspired by code from Jesse Glick <jglick@sig.bsh.com> and
# Peter Seibel <peter@weblogic.com>

package Error::subs;

use Exporter ();
use vars qw(@EXPORT_OK @ISA %EXPORT_TAGS);

@EXPORT_OK   = qw(try with finally except otherwise);
%EXPORT_TAGS = (try => \@EXPORT_OK);

@ISA = qw(Exporter);

sub run_clauses ($$$\@) {
    my($clauses,$err,$wantarray,$result) = @_;
    my $code = undef;

    $err = new Error::Simple($err) unless ref($err);

    CATCH: {

        # catch
        my $catch;
        if(defined($catch = $clauses->{'catch'})) {
            my $i = 0;

            CATCHLOOP:
            for( ; $i < @$catch ; $i += 2) {
                my $pkg = $catch->[$i];
                unless(defined $pkg) {
                    #except
                    splice(@$catch,$i,2,$catch->[$i+1]->());
                    $i -= 2;
                    next CATCHLOOP;
                }
                elsif($err->isa($pkg)) {
                    $code = $catch->[$i+1];
                    while(1) {
                        my $more = 0;
                        local($Error::THROWN);
                        my $ok = eval {
                            if($wantarray) {
                                @{$result} = $code->($err,\$more);
                            }
                            elsif(defined($wantarray)) {
                                @{$result} = ();
                                $result->[0] = $code->($err,\$more);
                            }
                            else {
                                $code->($err,\$more);
                            }
                            1;
                        };
                        if( $ok ) {
                            next CATCHLOOP if $more;
                            undef $err;
                        }
                        else {
                            $err = defined($Error::THROWN)
                                    ? $Error::THROWN : $@;
                            $err = new Error::Simple($err)
                                    unless ref($err);
                        }
                        last CATCH;
                    };
                }
            }
        }

        # otherwise
        my $owise;
        if(defined($owise = $clauses->{'otherwise'})) {
            my $code = $clauses->{'otherwise'};
            my $more = 0;
            my $ok = eval {
                if($wantarray) {
                    @{$result} = $code->($err,\$more);
                }
                elsif(defined($wantarray)) {
                    @{$result} = ();
                    $result->[0] = $code->($err,\$more);
                }
                else {
                    $code->($err,\$more);
                }
                1;
            };
            if( $ok ) {
                undef $err;
            }
            else {
                $err = defined($Error::THROWN)
                        ? $Error::THROWN : $@;
                $err = new Error::Simple($err)
                        unless ref($err);
            }
        }
    }
    $err;
}

sub try (&;$) {
    my $try = shift;
    my $clauses = @_ ? shift : {};
    my $ok = 0;
    my $err = undef;
    my @result = ();

    unshift @Error::STACK, $clauses;

    my $wantarray = wantarray();

    do {
        local $Error::THROWN = undef;

        $ok = eval {
            if($wantarray) {
                @result = $try->();
            }
            elsif(defined $wantarray) {
                $result[0] = $try->();
            }
            else {
                $try->();
            }
            1;
        };

        $err = defined($Error::THROWN) ? $Error::THROWN : $@
            unless $ok;
    };

    shift @Error::STACK;

    $err = run_clauses($clauses,$err,wantarray,@result)
        unless($ok);

    $clauses->{'finally'}->()
        if(defined($clauses->{'finally'}));

    throw $err if defined($err);

    wantarray ? @result : $result[0];
}

# Each clause adds a sub to the list of clauses. The finally clause is
# always the last, and the otherwise clause is always added just before
# the finally clause.
#
# All clauses, except the finally clause, add a sub which takes one argument
# this argument will be the error being thrown. The sub will return a code ref
# if that clause can handle that error, otherwise undef is returned.
#
# The otherwise clause adds a sub which unconditionally returns the users
# code reference, this is why it is forced to be last.
#
# The catch clause is defined in Error.pm, as the syntax causes it to
# be called as a method

sub with (&;$) {
    @_
}

sub finally (&) {
    my $code = shift;
    my $clauses = { 'finally' => $code };
    $clauses;
}

# The except clause is a block which returns a hashref or a list of
# key-value pairs, where the keys are the classes and the values are subs.

sub except (&;$) {
    my $code = shift;
    my $clauses = shift || {};
    my $catch = $clauses->{'catch'} ||= [];
    
    my $sub = sub {
        my $ref;
        my(@array) = $code->($_[0]);
        if(@array == 1 && ref($array[0])) {
            $ref = $array[0];
            $ref = [ %$ref ]
                if(UNIVERSAL::isa($ref,'HASH'));
        }
        else {
            $ref = \@array;
        }
        @$ref
    };

    unshift @{$catch}, undef, $sub;

    $clauses;
}

sub otherwise (&;$) {
    my $code = shift;
    my $clauses = shift || {};

    if(exists $clauses->{'otherwise'}) {
        require Carp;
        Carp::croak("Multiple otherwise clauses");
    }

    $clauses->{'otherwise'} = $code;

    $clauses;
}

1;
__END__

=head1 NAME

Error - Error/exception handling in an OO-ish way

=head1 SYNOPSIS

    use Error qw(:try);

    throw Error::Simple( "A simple error");

    sub xyz {
        ...
        record Error::Simple("A simple error")
            and return;
    }
 
    unlink($file) or throw Error::Simple("$file: $!",$!);

    try {
        do_some_stuff();
        die "error!" if $condition;
        throw Error::Simple -text => "Oops!" if $other_condition;
    }
    catch Error::IO with {
        my $E = shift;
        print STDERR "File ", $E->{'-file'}, " had a problem\n";
    }
    except {
        my $E = shift;
        my $general_handler=sub {send_message $E->{-description}};
        return {
            UserException1 => $general_handler,
            UserException2 => $general_handler
        };
    }
    otherwise {
        print STDERR "Well I don't know what to say\n";
    }
    finally {
        close_the_garage_door_already(); # Should be reliable
    }; # Don't forget the trailing ; or you might be surprised

=head1 DESCRIPTION

The C<Error> package provides two interfaces. Firstly C<Error> provides
a procedural interface to exception handling. Secondly C<Error> is a
base class for errors/exceptions that can either be thrown, for
subsequent catch, or can simply be recorded.

Errors in the class C<Error> should not be thrown directly, but the
user should throw errors from a sub-class of C<Error>.

=head1 PROCEDURAL INTERFACE

C<Error> exports subroutines to perform exception handling. These will
be exported if the C<:try> tag is used in the C<use> line.

=over 4

=item try BLOCK CLAUSES

C<try> is the main subroutine called by the user. All other subroutines
exported are clauses to the try subroutine.

The BLOCK will be evaluated and, if no error is throw, try will return
the result of the block.

C<CLAUSES> are the subroutines below, which describe what to do in the
event of an error being thrown within BLOCK.

=item catch CLASS with BLOCK

This clauses will cause all errors that satisfy C<$err-E<gt>isa(CLASS)>
to be caught and handled by evaluating C<BLOCK>.

C<BLOCK> will be passed two arguments. The first will be the error
being thrown. The second is a reference to a scalar variable. If this
variable is set by the catch block then, on return from the catch
block, try will continue processing as if the catch block was never
found.

To propagate the error the catch block may call C<$err-E<gt>throw>

If the scalar reference by the second argument is not set, and the
error is not thrown. Then the current try block will return with the
result from the catch block.

=item except BLOCK

When C<try> is looking for a handler, if an except clause is found
C<BLOCK> is evaluated. The return value from this block should be a
HASHREF or a list of key-value pairs, where the keys are class names
and the values are CODE references for the handler of errors of that
type.

=item otherwise BLOCK

Catch any error by executing the code in C<BLOCK>

When evaluated C<BLOCK> will be passed one argument, which will be the
error being processed.

Only one otherwise block may be specified per try block

=item finally BLOCK

Execute the code in C<BLOCK> either after the code in the try block has
successfully completed, or if the try block throws an error then
C<BLOCK> will be executed after the handler has completed.

If the handler throws an error then the error will be caught, the
finally block will be executed and the error will be re-thrown.

Only one finally block may be specified per try block

=back

=head1 CLASS INTERFACE

=head2 CONSTRUCTORS

The C<Error> object is implemented as a HASH. This HASH is initialized
with the arguments that are passed to it's constructor. The elements
that are used by, or are retrievable by the C<Error> class are listed
below, other classes may add to these.

        -file
        -line
        -text
        -value
        -object

If C<-file> or C<-line> are not specified in the constructor arguments
then these will be initialized with the file name and line number where
the constructor was called from.

If the error is associated with an object then the object should be
passed as the C<-object> argument. This will allow the C<Error> package
to associate the error with the object.

The C<Error> package remembers the last error created, and also the
last error associated with a package. This could either be the last
error created by a sub in that package, or the last error which passed
an object blessed into that package as the C<-object> argument.

=over 4

=item throw ( [ ARGS ] )

Create a new C<Error> object and throw an error, which will be caught
by a surrounding C<try> block, if there is one. Otherwise it will cause
the program to exit.

C<throw> may also be called on an existing error to re-throw it.

=item with ( [ ARGS ] )

Create a new C<Error> object and returns it. This is defined for
syntactic sugar, eg

    die with Some::Error ( ... );

=item record ( [ ARGS ] )

Create a new C<Error> object and returns it. This is defined for
syntactic sugar, eg

    record Some::Error ( ... )
        and return;

=back

=head2 STATIC METHODS

=over 4

=item prior ( [ PACKAGE ] )

Return the last error created, or the last error associated with
C<PACKAGE>

=back

=head2 OBJECT METHODS

=over 4

=item stacktrace

If the variable C<$Error::Debug> was non-zero when the error was
created, then C<stacktrace> returns a string created by calling
C<Carp::longmess>. If the variable was zero the C<stacktrace> returns
the text of the error appended with the filename and line number of
where the error was created, providing the text does not end with a
newline.

=item object

The object this error was associated with

=item file

The file where the constructor of this error was called from

=item line

The line where the constructor of this error was called from

=item text

The text of the error

=back

=head2 OVERLOAD METHODS

=over 4

=item stringify

A method that converts the object into a string. This method may simply
return the same as the C<text> method, or it may append more
information. For example the file name and line number.

By default this method returns the C<-text> argument that was passed to
the constructor, or the string C<"Died"> if none was given.

=item value

A method that will return a value that can be associated with the
error. For example if an error was created due to the failure of a
system call, then this may return the numeric value of C<$!> at the
time.

By default this method returns the C<-value> argument that was passed
to the constructor.

=back

=head1 PRE-DEFINED ERROR CLASSES

=over 4

=item Error::Simple

This class can be used to hold simple error strings and values. It's
constructor takes two arguments. The first is a text value, the second
is a numeric value. These values are what will be returned by the
overload methods.

If the text value ends with C<at file line 1> as $@ strings do, then
this infomation will be used to set the C<-file> and C<-line> arguments
of the error object.

This class is used internally if an eval'd block die's with an error
that is a plain string.

=back

=head1 KNOWN BUGS

None, but that does not mean there are not any.

=head1 AUTHORS

Graham Barr <gbarr@pobox.com>

The code that inspired me to write this was originally written by
Peter Seibel <peter@weblogic.com> and adapted by Jesse Glick
<jglick@sig.bsh.com>.

=head1 MAINTAINER

Arun Kumar U <u_arunkumar@yahoo.com>

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