File Coverage

blib/lib/errors.pm

Criterion	Covered	Total	%
statement	130	213	61.0
branch	37	114	32.4
condition	14	30	46.6
subroutine	23	32	71.8
pod	0	1	0.0
total	204	390	52.3

#  ToDo
# + Move Error.pm code into module
# + 'with' clashes with Moose
# + Remove Simple
# + Support $_ as error topic
#
# - Add system error classes
# - Support autodie
# - Move most Error stuff into errors package
# - Replace ObjectifyCallback
#
# == Tests
# + otherwise
# + except
# + -with_using
# + $_ is used
#
# - assert function works
# - $@ is always undef
# - nesting of try stuff
# - works with Moose
# - works with Error
# - with becomes using if with already exists

#------------------------------------------------------------------------------
use strict; use warnings;
package errors;
our $VERSION = '0.13';

sub import {
    my ($class, $directive) = @_;
    if (not $directive) {
        $class->export_commands(
            qw(try with except otherwise finally assert)
        );
    }
    elsif ($directive eq '-with_using') {
        $class->export_commands(
            qw(try using except otherwise finally assert)
        );
    }
    elsif ($directive eq '-class') {
        my ($class, %fields) = @_[2..$#_];
        my $isa = $fields{-isa} || 'Exception';
        no strict 'refs';
        @{$class . '::ISA'} = ($isa);
    }
    else {
        die "Invalid usage of errors module: 'use errors @_[1..$#_]'";
    }
}

sub export_commands {
    my ($class, @exports) = @_;
    local @errors::subs::EXPORT = @exports;
    local $Exporter::ExportLevel += 2;
    errors::subs->import();
}

#------------------------------------------------------------------------------
# Inspired by code from Jesse Glick and Peter Seibel

package errors::subs;

use Exporter ();
our @ISA = qw(Exporter);

sub objectify {
    my $msg = shift;
    return RuntimeError->new($msg);
}

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

    $err = objectify($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]->($err));
                    $i -= 2;
                    next CATCHLOOP;
                }
                elsif(Scalar::Util::blessed($err) && $err->isa($pkg)) {
                    $code = $catch->[$i+1];
                    while(1) {
                        my $more = 0;
                        local($Exception::THROWN, $@);
                        $_ = $@ = $err;
                        my $ok = eval {
                            $@ = $err;
                            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 = $@ || $Exception::THROWN;
                                $err = objectify($err)
                                        unless ref($err);
                        }
                        last CATCH;
                    };
                }
            }
        }

        # otherwise
        my $owise;
        if(defined($owise = $clauses->{'otherwise'})) {
            my $code = $clauses->{'otherwise'};
            my $more = 0;
        local($Exception::THROWN, $@);
            $_ = $@ = $err;
            my $ok = eval {
                $@ = $err;
                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 = $@ || $Exception::THROWN;

                $err = objectify($err)
                        unless ref($err);
            }
        }
    }
    undef $_;
    undef $@;
    return $err;
}

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

    my $wantarray = wantarray();

    do {
        local $Exception::THROWN = undef;
        local $@ = undef;

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

        $err = $@ || $Exception::THROWN
            unless $ok;
    };

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

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

    if (defined($err))
    {
        if (Scalar::Util::blessed($err) && $err->can('throw'))
        {
            throw $err;
        }
        else
        {
            die $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 Exception.pm, as the syntax causes it to
# be called as a method

sub with (&;$) {
    @_
}

sub using (&;$) {
    @_
}

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;
}

sub assert($$) {
    my ($value, $msg) = @_;
    return $value if $value;
    throw AssertionError($msg);
    die($msg);
}

#------------------------------------------------------------------------------
package Exception;

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

$Exception::Depth = 0;        # Depth to pass to caller()
$Exception::Debug = 0;        # Generate verbose stack traces
$Exception::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 errors::subs

use Scalar::Util ();

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

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;
}

sub flush {
    shift; #ignore

    unless (@_) {
       $LAST = undef;
       return;
    }

    my $pkg = shift;
    return unless ref($pkg);

    undef $ERROR{$pkg} if defined $ERROR{$pkg};
}

# Return as much information as possible about where the error
# happened. The -stacktrace element only exists if $Exception::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;
}


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($Exception::Depth);

    my $err = bless {
        '-package' => $pkg,
        '-file'    => $file,
        '-line'    => $line,
        ((@_ % 2) ? ('-text') : ()),
        @_
    }, $self;

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

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

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

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

    die $Exception::THROWN = $self;
}

# 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 RuntimeError;
our @ISA = 'Exception';

package AssertionError;
our @ISA = 'Exception';

1;