File Coverage

blib/lib/Dancer/Exception/Base.pm

Criterion	Covered	Total	%
statement	66	68	97.0
branch	8	10	80.0
condition	2	6	33.3
subroutine	17	19	89.4
pod	5	6	83.3
total	98	109	89.9

package Dancer::Exception::Base;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: the base class of all Dancer exceptions
$Dancer::Exception::Base::VERSION = '1.3514_04'; # TRIAL
$Dancer::Exception::Base::VERSION = '1.351404';
use strict;
use warnings;
use Carp;

use base qw(Exporter);

use Dancer::Exception;

use overload '""' => sub {
    my ($self) = @_;
    $self->message
      . ( $Dancer::Exception::Verbose ? $self->{_longmess} : $self->{_shortmess});
};

# string comparison is done without the stack traces
use overload 'cmp' => sub {
    my ($e, $f) = @_;
    ( ref $e && $e->isa(__PACKAGE__)
      ? $e->message : $e )
      cmp
    ( ref $f && $f->isa(__PACKAGE__)
      ? $f->message : $f )
};

# This is the base class of all exceptions

sub new {
    my $class = shift;
    my $self = bless { _raised_arguments => [],
                       _shortmess => '',
                       _longmess => '',
                     }, $class;
    $self->_raised_arguments(@_);
    return $self;
}

# base class has a passthrough message
sub _message_pattern { '%s' }

sub throw {
    my $self = shift;
    $self->_raised_arguments(@_);
    local $Carp::CarpInternal;
    local $Carp::Internal;
    $Carp::Internal{'Dancer'} ++;
    $Carp::CarpInternal{'Dancer::Exception'} ++;
    $self->{_shortmess} = Carp::shortmess;
    $self->{_longmess} = Carp::longmess;
    die $self;
}

sub rethrow { die $_[0] }

sub message {
    my ($self) = @_;
    my $message_pattern = $self->_message_pattern;
    my $message = sprintf($message_pattern, @{$self->_raised_arguments});
    return $message;
}

sub does {
    my $self = shift;
    my $regexp = join('|', map { '^' . $_ . '$'; } @_);
    (scalar grep { /$regexp/ } $self->get_composition) >= 1;
}

sub get_composition {
    my ($self) = @_;
    my $class = ref($self);

    my ($_recurse_isa, %seen);
    $_recurse_isa = sub {
        my ($class) = @_;
        $seen{$class}++
          and return;

        no strict 'refs';
        return $class, map { $_recurse_isa->($_) }
                      grep { /^Dancer::Exception::/ }
                          @{"${class}::ISA"};

    };
    grep { s/^Dancer::Exception::// } $_recurse_isa->($class);
}

sub _raised_arguments {
    my $self = shift;
    @_ and $self->{_raised_arguments} = [ @_ ];
    $self->{_raised_arguments};
}

1;

__END__