File Coverage

blib/lib/Exception/Class/Base.pm

Criterion	Covered	Total	%
statement	115	124	92.7
branch	30	42	71.4
condition	7	17	41.1
subroutine	26	28	92.8
pod	10	13	76.9
total	188	224	83.9

package Exception::Class::Base;

use strict;
use warnings;

our $VERSION = '1.45';

use Class::Data::Inheritable 0.02;
use Devel::StackTrace 2.00;
use Scalar::Util qw( blessed );

use base qw(Class::Data::Inheritable);

BEGIN {
    __PACKAGE__->mk_classdata('Trace');
    __PACKAGE__->mk_classdata('UnsafeRefCapture');

    __PACKAGE__->mk_classdata('NoContextInfo');
    __PACKAGE__->NoContextInfo(0);

    __PACKAGE__->mk_classdata('RespectOverload');
    __PACKAGE__->RespectOverload(0);

    __PACKAGE__->mk_classdata('MaxArgLength');
    __PACKAGE__->MaxArgLength(0);

    sub NoRefs {
        my $self = shift;
        if (@_) {
            my $val = shift;
            return $self->UnsafeRefCapture( !$val );
        }
        else {
            return $self->UnsafeRefCapture;
        }
    }

    sub Fields { () }
}

use overload

    # an exception is always true
    bool => sub {1}, '""' => 'as_string', fallback => 1;

# Create accessor routines
BEGIN {
    my @fields = qw( message pid uid euid gid egid time trace );

    foreach my $f (@fields) {
        my $sub = sub { my $s = shift; return $s->{$f}; };

        ## no critic (TestingAndDebugging::ProhibitNoStrict)
        no strict 'refs';
        *{$f} = $sub;
    }
    *error = \&message;

    my %trace_fields = (
        package => 'package',
        file    => 'filename',
        line    => 'line',
    );

    while ( my ( $f, $m ) = each %trace_fields ) {
        my $sub = sub {
            my $s = shift;
            return $s->{$f} if exists $s->{$f};

            my $frame = $s->trace->frame(0);

            return $s->{$f} = $frame ? $frame->$m : undef;
        };

        ## no critic (TestingAndDebugging::ProhibitNoStrict)
        no strict 'refs';
        *{$f} = $sub;
    }
}

sub Classes { Exception::Class::Classes() }

sub throw {
    my $proto = shift;

    $proto->rethrow if ref $proto;

    die $proto->new(@_);
}

sub rethrow {
    my $self = shift;

    die $self;
}

sub new {
    my $proto = shift;
    my $class = ref $proto || $proto;

    my $self = bless {}, $class;

    $self->_initialize(@_);

    return $self;
}

sub _initialize {
    my $self = shift;
    my %p    = @_ == 1 ? ( error => $_[0] ) : @_;

    $self->{message} = $p{message} || $p{error} || q{};

    $self->{show_trace} = $p{show_trace} if exists $p{show_trace};

    if ( $self->NoContextInfo ) {
        $self->{show_trace} = 0;
        $self->{package}    = $self->{file} = $self->{line} = undef;
    }
    else {
        # CORE::time is important to fix an error with some versions of
        # Perl
        $self->{time} = CORE::time();
        $self->{pid}  = $$;
        $self->{uid}  = $<;
        $self->{euid} = $>;
        $self->{gid}  = $(;
        $self->{egid} = $);

        my @ignore_class   = (__PACKAGE__);
        my @ignore_package = 'Exception::Class';

        if ( my $i = delete $p{ignore_class} ) {
            push @ignore_class, ( ref($i) eq 'ARRAY' ? @$i : $i );
        }

        if ( my $i = delete $p{ignore_package} ) {
            push @ignore_package, ( ref($i) eq 'ARRAY' ? @$i : $i );
        }

        $self->{trace} = Devel::StackTrace->new(
            ignore_class       => \@ignore_class,
            ignore_package     => \@ignore_package,
            unsafe_ref_capture => $self->UnsafeRefCapture,
            respect_overload   => $self->RespectOverload,
            max_arg_length     => $self->MaxArgLength,
            map { $p{$_} ? ( $_ => delete $p{$_} ) : () } qw(
                frame_filter
                filter_frames_early
                skip_frames
            ),
        );
    }

    my %fields = map { $_ => 1 } $self->Fields;
    while ( my ( $key, $value ) = each %p ) {
        next if $key =~ /^(?:error|message|show_trace)$/;

        if ( $fields{$key} ) {
            $self->{$key} = $value;
        }
        else {
            Exception::Class::Base->throw(
                error => "unknown field $key passed to constructor for class "
                    . ref $self );
        }
    }
}

sub context_hash {
    my $self = shift;

    return {
        time => $self->{time},
        pid  => $self->{pid},
        uid  => $self->{uid},
        euid => $self->{euid},
        gid  => $self->{gid},
        egid => $self->{egid},
    };
}

sub field_hash {
    my $self = shift;

    my $hash = {};

    for my $field ( $self->Fields ) {
        $hash->{$field} = $self->$field;
    }

    return $hash;
}

sub description {
    return 'Generic exception';
}

sub show_trace {
    my $self = shift;

    return 0 unless $self->{trace};

    if (@_) {
        $self->{show_trace} = shift;
    }

    return exists $self->{show_trace} ? $self->{show_trace} : $self->Trace;
}

sub as_string {
    my $self = shift;

    my $str = $self->full_message;
    unless ( defined $str && length $str ) {
        my $desc = $self->description;
        $str = defined $desc
            && length $desc ? "[$desc]" : '[Generic exception]';
    }

    $str .= "\n\n" . $self->trace->as_string
        if $self->show_trace;

    return $str;
}

sub full_message { $_[0]->message }

#
# The %seen bit protects against circular inheritance.
#
## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
eval <<'EOF' if $] == 5.006;
sub isa {
    my ( $inheritor, $base ) = @_;
    $inheritor = ref($inheritor) if ref($inheritor);

    my %seen;

    no strict 'refs';
    my @parents = ( $inheritor, @{"$inheritor\::ISA"} );
    while ( my $class = shift @parents ) {
        return 1 if $class eq $base;

        push @parents, grep { !$seen{$_}++ } @{"$class\::ISA"};
    }
    return 0;
}
EOF

sub caught {
    my $class = shift;

    my $e = $@;

    return unless defined $e && blessed($e) && $e->isa($class);
    return $e;
}

1;

# ABSTRACT: A base class for exception objects

__END__