File Coverage

lib/Unexpected/TraitFor/Throwing.pm
Criterion Covered Total %
statement 40 40 100.0
branch 14 14 100.0
condition 5 5 100.0
subroutine 12 12 100.0
pod 4 4 100.0
total 75 75 100.0


line stmt bran cond sub pod time code
1             package Unexpected::TraitFor::Throwing;
2              
3 4     4   2035 use namespace::autoclean;
  4         14  
  4         44  
4              
5 4     4   375 use Carp ( );
  4         12  
  4         104  
6 4     4   26 use English qw( -no_match_vars );
  4         11  
  4         34  
7 4     4   1913 use Scalar::Util qw( blessed );
  4         12  
  4         249  
8 4     4   30 use Unexpected::Functions qw( is_one_of_us parse_arg_list );
  4         14  
  4         36  
9 4     4   1118 use Unexpected::Types qw( Maybe Object );
  4         12  
  4         33  
10 4     4   4385 use Moo::Role;
  4         13  
  4         35  
11              
12             requires qw( BUILD );
13              
14             # Private functions
15             my $_cache_key = sub {
16             # uncoverable branch true
17             return $PID.'-'.(exists $INC{ 'threads.pm' } ? threads->tid() : 0);
18             };
19              
20             my $_exception_cache = {};
21              
22             # Public attributes. Lifted from Throwable
23             has 'previous_exception' => is => 'ro', isa => Maybe[Object],
24 30     30   4915 builder => sub { $_exception_cache->{ $_cache_key->() } };
25              
26             # Construction
27             after 'BUILD' => sub {
28             my $self = shift; my $e = $self->clone; delete $e->{previous_exception};
29              
30             $_exception_cache->{ $_cache_key->() } = $e;
31              
32             return;
33             };
34              
35             # Private methods
36             my $_is_object_ref = sub {
37             my ($self, @args) = @_; blessed $self or return 0;
38              
39             scalar @args and Carp::confess
40             'Trying to throw an Exception object with arguments';
41             return 1;
42             };
43              
44             # Public methods
45             sub caught {
46 10     10 1 2119 my ($self, @args) = @_;
47              
48 10 100       49 $self->$_is_object_ref( @args ) and return $self;
49              
50 9         54 my $attr = parse_arg_list @args;
51 9 100 100     92 my $error = $attr->{error} ||= $EVAL_ERROR; $error or return;
  9         62  
52              
53 8 100       61 return (is_one_of_us $error) ? $error : $self->new( $attr );
54             }
55              
56             sub clone {
57 33     33 1 1946 my ($self, $args) = @_;
58              
59 33 100       250 my $class = blessed $self or $self->throw( 'Clone is an object method' );
60              
61 32   100     110 return bless { %{ $self }, %{ $args // {} } }, $class;
  32         186  
  32         525  
62             }
63              
64             sub throw {
65 30     30 1 15394 my ($self, @args) = @_;
66              
67 30 100       173 $self->$_is_object_ref( @args ) and die $self;
68 28 100       194 is_one_of_us $args[ 0 ] and die $args[ 0 ];
69 27         952 die $self->new( @args );
70             }
71              
72             sub throw_on_error {
73 4 100   4 1 444 my $e; $e = shift->caught( @_ ) and die $e; return;
  4         27  
  1         6  
74             }
75              
76             1;
77              
78             __END__