File Coverage

lib/Unexpected/TraitFor/ExceptionClasses.pm

Criterion	Covered	Total	%
statement	31	31	100.0
branch	20	20	100.0
condition	7	7	100.0
subroutine	6	6	100.0
pod	3	3	100.0
total	67	67	100.0

package Unexpected::TraitFor::ExceptionClasses;

use namespace::autoclean;

use Unexpected::Functions qw( inflate_message );
use Moo::Role;

my $ROOT = 'Unexpected'; my $Classes = { $ROOT => {} };

__PACKAGE__->add_exception( 'Unspecified' => {
   parents => $ROOT, error => 'Parameter [_1] not specified' } );

# Public attributes
has 'class' => is => 'ro', isa => sub {
   ($_[ 0 ] and exists $Classes->{ $_[ 0 ] }) or die inflate_message
      ( 'Exception class [_1] does not exist', $_[ 0 ] ) }, default => $ROOT;

# Construction
around 'BUILDARGS' => sub {
   my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args ); my $class;

   (exists $attr->{class} and $class = $attr->{class}) or return $attr;

   ref $class eq 'CODE' and $class = $attr->{class} = $class->();

   $self->is_exception( $class ) or return $attr;

   for my $k (grep { ! m{ \A parents \z }mx } keys %{ $Classes->{ $class } }) {
      $attr->{ $k } //= $Classes->{ $class }->{ $k };
   }

   return $attr;
};

# Public class methods
sub add_exception {
   my ($self, $class, $args) = @_; $args //= {};

   defined $class or die "Parameter 'exception class' not specified";

   exists $Classes->{ $class }
      and die "Exception class ${class} already exists";

   ref $args ne 'HASH' and $args = { parents => $args };

   my $parents = $args->{parents} //= [ $ROOT ];

   ref $parents ne 'ARRAY' and $parents = $args->{parents} = [ $parents ];

   for my $parent (@{ $parents }) {
      exists $Classes->{ $parent } or die
         "Exception class ${class} parent class ${parent} does not exist";
   }

   $Classes->{ $class } = $args;
   return;
}

sub is_exception {
   return $_[ 1 ] && !ref $_[ 1 ] && exists $Classes->{ $_[ 1 ] } ? 1 : 0;
}

# Public object methods
sub instance_of {
   my ($self, $wanted) = @_; $wanted or return 0;

   exists $Classes->{ $wanted }
      or die "Exception class ${wanted} does not exist";

   my @classes = ( $self->class );

   while (defined (my $class = shift @classes)) {
      $class eq $wanted and return 1;
      exists $Classes->{ $class }->{parents}
         and push @classes, @{ $Classes->{ $class }->{parents} };
   }

   return 0;
}

1;

__END__