File Coverage

blib/lib/Class/Throwable.pm

Criterion	Covered	Total	%
statement	108	108	100.0
branch	49	50	98.0
condition	14	22	63.6
subroutine	19	19	100.0
pod	10	10	100.0
total	200	209	95.6

package Class::Throwable;

use strict;
use warnings;

our $VERSION = '0.13';

use Scalar::Util qw(blessed);

our $DEFAULT_VERBOSITY = 1;

my %VERBOSITY;

# allow the creation of exceptions
# without having to actually create
# a package for them
sub import {
	my $class = shift;
    return unless @_;
	if ($_[0] eq 'VERBOSE') {
		(defined $_[1]) || die "You must specify a level of verbosity with Class::Throwable\n";
		# make sure its not a refernce
		$class = ref($class) || $class;
		# and then store it
		$VERBOSITY{$class} = $_[1];
	}
    elsif ($_[0] eq 'retrofit') {
		(defined $_[1]) || die "You must specify a module for Class::Throwable to retrofit\n";
        my $package = $_[1];
        my $retrofitter = sub { Class::Throwable->throw(@_) };
        $retrofitter = $_[2] if defined $_[2] && ref($_[2]) eq 'CODE';
        eval {
            no strict 'refs';
            *{"${package}::die"} = $retrofitter;
        };
        die "Could not retrofit '$package' with Class::Throwable : $@\n" if $@;
    }
	else {
		($class eq 'Class::Throwable')
			|| die "Inline Exceptions can only be created with Class::Throwable\n";
		my @exceptions = @_;
		foreach my $exception (@exceptions) {
			next unless $exception;
			eval "package ${exception}; \@${exception}::ISA = qw(Class::Throwable);";
			die "An error occured while constructing Class::Throwable exception ($exception) : $@\n" if $@;
		}
	}
}

# overload the stringify operation
use overload q|""| => "toString", fallback => 1;

# a class method to set the verbosity
# of inline exceptions
sub setVerbosity {
	my ($class, $verbosity) = @_;
	(!ref($class)) || die "setVerbosity is a class method only, it cannot be used on an instance\n";
	(defined($verbosity)) || die "You must specify a level of verbosity with Class::Throwable\n";
	$VERBOSITY{$class} = $verbosity;
}

# create an exception without
# any stack trace information
sub new {
	my ($class, $message, $sub_exception) = @_;
	my $exception = {};
	bless($exception, ref($class) || $class);
	$exception->_init($message, $sub_exception);
	return $exception;
}

# throw an exception with this
sub throw {
	my ($class, $message, $sub_exception) = @_;
	# if i am being re-thrown, then just die with the class
	if (blessed($class) && $class->isa("Class::Throwable")) {
		# first make sure we have a stack trace, if we
		# don't then we were likely created with 'new'
		# and not 'throw', and so we need to gather the
		# stack information from here
		$class->_initStackTrace() unless my @s = $class->getStackTrace();
		die $class;
	}
	# otherwise i am being thrown for the first time so
	# create a new 'me' and then die after i am blessed
	my $exception = {};
	bless($exception, $class);
	$exception->_init($message, $sub_exception);
	# init our stack trace
	$exception->_initStackTrace();
	die $exception;
}

## initializers

sub _init {
	my ($self, $message, $sub_exception) = @_;
    # the sub-exception is another exception
    # which has already been caught, and is
    # the cause of this exception being thrown
    # so we dont want to loose that information
    # so we store it here
    # NOTE:
    # we do not enforce the type of exception here
    # becuase it is possible this was thrown by
    # perl itself and therefore could be a string
    $self->{sub_exception} = $sub_exception;
	$self->{message} = $message || "An ". ref($self) . " Exception has been thrown";
	$self->{stack_trace} = [];
}

sub _initStackTrace {
	my ($self) = @_;
	my @stack_trace;
    # these are the 10 values returned from caller():
    # 	$package, $filename, $line, $subroutine, $hasargs,
    # 	$wantarray, $evaltext, $is_require, $hints, $bitmask
    # we do not bother to capture the last two as they are
    # subject to change and not meant for internal use
    {
        package DB;
        my $i = 1;
        my @c;
        while (@c = caller($i++)) {
            # dont bother to get our caller
            next if $c[3] =~ /Class\:\:Throwable\:\:throw/;
            push @stack_trace, [ @c[0 .. 7] ];
        }
    }
	$self->{stack_trace} = \@stack_trace;
}

# accessors

sub hasSubException {
    my ($self) = @_;
    return defined $self->{sub_exception} ? 1 : 0;
}

sub getSubException {
    my ($self) = @_;
    return $self->{sub_exception};
}

sub getMessage {
	my ($self) = @_;
	return $self->{"message"};
}

sub getStackTrace {
    my ($self) = @_;
    return wantarray ?
                @{$self->{stack_trace}}
                :
                $self->{stack_trace};
}

sub stackTraceToString {
	my ($self, $depth) = @_;
	my @output;
    $depth ||= 1;
    my $indent = "  " x $depth;
	foreach my $frame (@{$self->{stack_trace}}) {
		my ($package, $filename, $line, $subroutine) = @{$frame};
        $subroutine = "${package}::${subroutine}" if ($subroutine eq '(eval)');
		push @output, "$indent|--[ $subroutine called in $filename line $line ]"
	}
	return (join "\n" => @output);
}

sub toString {
	my ($self, $verbosity, $depth) = @_;
	unless (defined $verbosity) {
		if (exists $VERBOSITY{ref($self)}) {
			$verbosity = $VERBOSITY{ref($self)};
		}
		else {
			$verbosity = $DEFAULT_VERBOSITY;
		}
	}
    # get out of here quick if
    # exception handling is off
    return "" if $verbosity <= 0;
    # otherwise construct our output
    my $output = ref($self) . " : " . $self->{"message"};
    # if we VERBOSE is set to 1, then
    # we just return the message
    return $output if $verbosity <= 1;
    $depth ||= 1;
    if ($depth > 1) {
        $output = ("  " x ($depth - 1)) . "+ $output";
        $depth++;
    }
    # however, if VERBOSE is 2 or above
    # then we include the stack trace
	$output .= "\n" . (join "\n" => $self->stackTraceToString($depth)) . "\n";
    # now we gather any sub-exceptions too
    if ($self->hasSubException()) {
        my $e = $self->getSubException();
        # make sure the sub-exception is one
        # of our objects, and ....
        if (blessed($e) && $e->isa("Class::Throwable")) {
            # deal with it appropriately
            $output .= $e->toString($verbosity, $depth + 1);
        }
        # otherwise ...
        else {
            # just stringify it
            $output .= ("  " x ($depth)) . "+ $e";
        }
    }
    return $output;
}

sub stringValue {
    my ($self) = @_;
    return overload::StrVal($self);
}

1;

__END__