File Coverage

lib/Unexpected/TraitFor/ExceptionClasses.pm
Criterion Covered Total %
statement 32 32 100.0
branch 22 22 100.0
condition 7 7 100.0
subroutine 6 6 100.0
pod 3 3 100.0
total 70 70 100.0


line stmt bran cond sub pod time code
1             package Unexpected::TraitFor::ExceptionClasses;
2              
3 2     2   8833 use namespace::autoclean;
  2         6  
  2         19  
4              
5 2     2   196 use Unexpected::Functions qw( inflate_message );
  2         6  
  2         21  
6 2     2   16 use Moo::Role;
  2         5  
  2         17  
7              
8             my $ROOT = 'Unexpected'; my $Classes = { $ROOT => {} };
9              
10             __PACKAGE__->add_exception( 'Unspecified' => {
11             parents => $ROOT, error => 'Parameter [_1] not specified' } );
12              
13             # Public attributes
14             has 'class' => is => 'ro', isa => sub {
15             ($_[ 0 ] and exists $Classes->{ $_[ 0 ] }) or die inflate_message
16             ( 'Exception class [_1] does not exist', $_[ 0 ] ) }, default => $ROOT;
17              
18             # Construction
19             around 'BUILDARGS' => sub {
20             my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args ); my $class;
21              
22             (exists $attr->{class} and $class = $attr->{class}) or return $attr;
23              
24             ref $class eq 'CODE' and $class = $attr->{class} = $class->();
25              
26             $self->is_exception( $class ) or return $attr;
27              
28             for my $k (grep { ! m{ \A parents \z }mx } keys %{ $Classes->{ $class } }) {
29             $attr->{ $k } //= $Classes->{ $class }->{ $k };
30             }
31              
32             return $attr;
33             };
34              
35             # Public class methods
36             sub add_exception {
37 15   100 15 1 6823 my ($self, $class, $args) = @_; $args //= {};
  15         61  
38              
39 15 100       56 defined $class or die "Parameter 'exception class' not specified";
40              
41 14 100       59 exists $Classes->{ $class }
42             and die "Exception class ${class} already exists";
43              
44 13 100       51 ref $args ne 'HASH' and $args = { parents => $args };
45              
46 13   100     62 my $parents = $args->{parents} //= [ $ROOT ];
47              
48 13 100       55 ref $parents ne 'ARRAY' and $parents = $args->{parents} = [ $parents ];
49              
50 13         29 for my $parent (@{ $parents }) {
  13         38  
51 15 100       62 exists $Classes->{ $parent } or die
52             "Exception class ${class} parent class ${parent} does not exist";
53             }
54              
55 12         33 $Classes->{ $class } = $args;
56 12         36 return;
57             }
58              
59             sub is_exception {
60 22 100 100 22 1 983 return $_[ 1 ] && !ref $_[ 1 ] && exists $Classes->{ $_[ 1 ] } ? 1 : 0;
61             }
62              
63             # Public object methods
64             sub instance_of {
65 11 100   11 1 1874 my ($self, $wanted) = @_; $wanted or return 0;
  11         56  
66              
67 10 100       53 ref $wanted eq 'CODE' and $wanted = $wanted->();
68              
69 10 100       69 exists $Classes->{ $wanted }
70             or die "Exception class ${wanted} does not exist";
71              
72 9         57 my @classes = ( $self->class );
73              
74 9         54 while (defined (my $class = shift @classes)) {
75 22 100       146 $class eq $wanted and return 1;
76             exists $Classes->{ $class }->{parents}
77 15 100       63 and push @classes, @{ $Classes->{ $class }->{parents} };
  12         70  
78             }
79              
80 2         20 return 0;
81             }
82              
83             1;
84              
85             __END__