File Coverage

blib/lib/Error/Hierarchy.pm

Criterion	Covered	Total	%
statement	41	53	77.3
branch	11	20	55.0
condition	1	6	16.6
subroutine	13	16	81.2
pod	7	7	100.0
total	73	102	71.5

use 5.008;
use strict;
use warnings;

package Error::Hierarchy;
BEGIN {
  $Error::Hierarchy::VERSION = '1.103530';
}
# ABSTRACT: Support for hierarchical exception classes
use Carp;
use Data::UUID;
use Sys::Hostname;
use parent 'Error::Hierarchy::Base';
__PACKAGE__
    ->mk_boolean_accessors(qw(is_optional acknowledged))
    ->mk_accessors(qw(
        message exception_hostname package filename line depth stacktrace uuid
    ));

# properties() is used for introspection by code that's catching exceptions.
# This code can be left generic as each exception class will know its own
# properties. This is useful for something like gettext-based error messages.
# Of course, each exception class also supports its own message construction
# via message() and stringify(). Exception handling code can decide which
# message construction system it wants.
use constant default_message => 'Died';

# sub properties { () }     # empty list, base class defines no properties
sub error_depth { 1 }

sub init {
    my $self = shift;
    $self->message($self->default_message) unless $self->message;
    $self->depth(0)                        unless defined $self->depth;
    $self->is_optional(0)                  unless defined $self->is_optional;

    # init() code is based on Error::new(); we use a slightly different
    # scheme to set caller information. Error::throw() (our superclass) sets
    # $Error::Depth. We use $Error::Depth + 1 because we init() got called by
    # new(), so the call stack is one deeper than $Error::Depth indicates.
    my ($package, $filename, $line) =
      caller($Error::Depth + $self->error_depth + $self->depth);
    $self->exception_hostname(hostname());
    $self->package($package)   unless defined $self->package;
    $self->filename($filename) unless defined $self->filename;
    $self->line($line)         unless defined $self->line;
    $self->stacktrace(Carp::longmess);
    $self->uuid(Data::UUID->new->create_str);
}
sub get_properties { $_[0]->every_list('PROPERTIES') }

sub properties_as_hash {
    my $self = shift;
    my %p = map { $_ => (defined $self->$_ ? $self->$_ : 'unknown') }

      # hm... ask gr...
      grep { $_ ne 'package' && $_ ne 'filename' && $_ ne 'line' }
      $self->get_properties;
    wantarray ? %p : \%p;
}

sub stringify {
    my $self = shift;
    my $message = $self->message || $self->default_message;
    sprintf $message => map { $self->$_ || 'unknown' }
      $self->get_properties;
}

sub transmute {
    my ($class, $E, %args) = @_;
    bless $E, $class;

    # can't just %$E = (%$E, %args) because the accessors might do more than
    # set a hash value
    while (my ($key, $value) = each %args) {
        $E->$key($value);
    }
}

sub comparable {
    my $self = shift;
    $self->stringify;
}
1;


__END__