File Coverage

blib/lib/Error.pm

Criterion	Covered	Total	%
statement	201	249	80.7
branch	63	112	56.2
condition	16	28	57.1
subroutine	33	38	86.8
pod	17	17	100.0
total	330	444	74.3

# Error.pm
#
# Copyright (c) 1997-8 Graham Barr . 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
#  and adapted by Jesse Glick .
#
# but modified ***significantly***

package Error;
$Error::VERSION = '0.17027';
use strict;
use warnings;

use 5.004;

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

sub _throw_Error_Simple
{
    my $args = shift;
    return Error::Simple->new( $args->{'text'} );
}

$Error::ObjectifyCallback = \&_throw_Error_Simple;

# Exported subs are defined in Error::subs

use Scalar::Util ();

sub import
{
    shift;
    my @tags = @_;
    local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;

    @tags = grep {
        if ( $_ eq ':warndie' )
        {
            Error::WarnDie->import();
            0;
        }
        else
        {
            1;
        }
    } @tags;

    Error::subs->import(@tags);
}

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

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

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::VERSION = '0.17027';
@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/\s+at\s+(\S+)\s+line\s+(\d+)(?:,\s*<[^>]*>\s+line\s+\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  and
# Peter Seibel

package Error::subs;
$Error::subs::VERSION = '0.17027';
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 = $Error::ObjectifyCallback->( { 'text' => $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 ( $Error::THROWN, $@ );
                        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 = $@ || $Error::THROWN;
                            $err = $Error::ObjectifyCallback->(
                                { 'text' => $err } )
                                unless ref($err);
                        }
                        last CATCH;
                    }
                }
            }
        }

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

                $err = $Error::ObjectifyCallback->( { 'text' => $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;
        local $@             = undef;

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

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

    shift @Error::STACK;

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

package Error::WarnDie;
$Error::WarnDie::VERSION = '0.17027';
sub gen_callstack($)
{
    my ($start) = @_;

    require Carp;
    local $Carp::CarpLevel = $start;
    my $trace = Carp::longmess("");

    # 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;
    my @callstack = split( m/\n/, $trace );
    return @callstack;
}

my $old_DIE;
my $old_WARN;

sub DEATH
{
    my ($e) = @_;

    local $SIG{__DIE__} = $old_DIE if ( defined $old_DIE );

    die @_ if $^S;

    my ( $etype, $message, $location, @callstack );
    if ( ref($e) && $e->isa("Error") )
    {
        $etype     = "exception of type " . ref($e);
        $message   = $e->text;
        $location  = $e->file . ":" . $e->line;
        @callstack = split( m/\n/, $e->stacktrace );
    }
    else
    {
        # Don't apply subsequent layer of message formatting
        die $e if ( $e =~ m/^\nUnhandled perl error caught at toplevel:\n\n/ );
        $etype = "perl error";
        my $stackdepth = 0;
        while ( caller($stackdepth) =~ m/^Error(?:$|::)/ )
        {
            $stackdepth++;
        }

        @callstack = gen_callstack( $stackdepth + 1 );

        $message = "$e";
        chomp $message;

        if ( $message =~ s/ at (.*?) line (\d+)\.$// )
        {
            $location = $1 . ":" . $2;
        }
        else
        {
            my @caller = caller($stackdepth);
            $location = $caller[1] . ":" . $caller[2];
        }
    }

    shift @callstack;

    # Do it this way in case there are no elements; we don't print a spurious \n
    my $callstack = join( "", map { "$_\n" } @callstack );

    die
"\nUnhandled $etype caught at toplevel:\n\n  $message\n\nThrown from: $location\n\nFull stack trace:\n\n$callstack\n";
}

sub TAXES
{
    my ($message) = @_;

    local $SIG{__WARN__} = $old_WARN if ( defined $old_WARN );

    $message =~ s/ at .*? line \d+\.$//;
    chomp $message;

    my @callstack = gen_callstack(1);
    my $location  = shift @callstack;

    # $location already starts in a leading space
    $message .= $location;

    # Do it this way in case there are no elements; we don't print a spurious \n
    my $callstack = join( "", map { "$_\n" } @callstack );

    warn "$message:\n$callstack";
}

sub import
{
    $old_DIE  = $SIG{__DIE__};
    $old_WARN = $SIG{__WARN__};

    $SIG{__DIE__}  = \&DEATH;
    $SIG{__WARN__} = \&TAXES;
}

1;

__END__