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	wakaba	1.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