File Coverage

blib/lib/SPOPS/Exception.pm

Criterion	Covered	Total	%
statement	53	61	86.8
branch	5	12	41.6
condition			n/a
subroutine	14	17	82.3
pod	0	10	0.0
total	72	100	72.0

package SPOPS::Exception;

# $Id: Exception.pm,v 3.5 2004/06/02 00:48:21 lachoy Exp $

use strict;
use base qw( Class::Accessor Exporter );
use overload '""' => \&stringify;
use Devel::StackTrace;
use SPOPS::Error;

$SPOPS::Exception::VERSION   = sprintf("%d.%02d", q$Revision: 3.5 $ =~ /(\d+)\.(\d+)/);
@SPOPS::Exception::EXPORT_OK = qw( spops_error );

use constant DEBUG => 0;

my @STACK  = ();
my @FIELDS = qw( message package filename line method trace );
SPOPS::Exception->mk_accessors( @FIELDS );

########################################
# SHORTCUT

sub spops_error { goto &throw( 'SPOPS::Exception', @_ ) }


########################################
# CLASS METHODS

sub throw {
    my ( $class, @message ) = @_;

    if ( ref $message[0] ) {
        my $rethrown = $message[0];
        if ( UNIVERSAL::isa( $rethrown, __PACKAGE__ ) ) {
            die $rethrown;
        }
    }

    my $params = ( ref $message[-1] eq 'HASH' )
                   ? pop( @message ) : {};
    my $msg    = join( '', @message );

    my $self = bless( {}, $class );

    # Do all the fields

    foreach my $field ( $self->get_fields ) {
        $self->$field( $params->{ $field } ) if ( $params->{ $field } );
    }

    # Now do the message and the initial trace stuff

    $self->message( $msg );

    my @initial_call = caller;
    $self->package( $initial_call[0] );
    $self->filename( $initial_call[1] );
    $self->line( $initial_call[2] );

    # Grab the method name separately, since the subroutine call
    # doesn't seem to be matched up properly with the other caller()
    # stuff when we do caller(0). Weird.

    my @added_call = caller(1);
    $added_call[3] =~ s/^.*:://;
    $self->method( $added_call[3] );

    $self->trace( Devel::StackTrace->new );

    DEBUG && warn "[$class] thrown: ", $self->message, "\n";

    $self->initialize( $params );

    push @STACK, $self;

    # BACKWARDS COMPATIBILITY (will remove before 1.0)

    $self->fill_error_variables;

    die $self;
}

sub initialize {}

sub get_fields { return @FIELDS }

sub get_stack   { return @STACK }
sub clear_stack { @STACK = ()   }


########################################
# OBJECT METHODS

sub creation_location {
    my ( $self ) = @_;
    return 'Created in package [' . $self->package . '] ' .
           'in method [' . $self->method . ']; ' .
           'at file [' . $self->filename . '] ' .
           'at line [' . $self->line . ']';
}

sub stringify   { return $_[0]->to_string() }

sub to_string   {
    my ( $self ) = @_;
    my $class = ref $self;
    return "Invalid -- not called from object."  unless ( $class );

    no strict 'refs';
    return $self->message()                      unless ( ${ $class . '::ShowTrace' } );
    return join( "\n", $self->message, $self->trace->as_string );
}

# BACKWARDS COMPATIBILITY (will remove before 1.0)

sub fill_error_variables {
    my ( $self ) = @_;
    SPOPS::Error->set({ user_msg => $self->message,  system_msg => $self->message,
                        package  => $self->package,  method     => $self->method,
                        filename => $self->filename, line       => $self->line });
}

1;

__END__