File Coverage

blib/lib/Dancer/Exception/Base.pm
Criterion Covered Total %
statement 66 68 97.0
branch 8 10 80.0
condition 2 6 33.3
subroutine 17 19 89.4
pod 5 6 83.3
total 98 109 89.9


line stmt bran cond sub pod time code
1             package Dancer::Exception::Base;
2             our $AUTHORITY = 'cpan:SUKRIA';
3             #ABSTRACT: the base class of all Dancer exceptions
4             $Dancer::Exception::Base::VERSION = '1.3521';
5 205     205   1375 use strict;
  205         427  
  205         7550  
6 205     205   2717 use warnings;
  205         430  
  205         8257  
7 205     205   991 use Carp;
  205         2274  
  205         12229  
8              
9 205     205   1386 use base qw(Exporter);
  205         575  
  205         34350  
10              
11 205     205   1563 use Dancer::Exception;
  205         500  
  205         18982  
12              
13             use overload '""' => sub {
14 58     58   11334 my ($self) = @_;
15             $self->message
16 58 100       286 . ( $Dancer::Exception::Verbose ? $self->{_longmess} : $self->{_shortmess});
17 205     205   230794 };
  205         192707  
  205         3943  
18              
19             # string comparison is done without the stack traces
20             use overload 'cmp' => sub {
21 2     2   505 my ($e, $f) = @_;
22 2 50 33     31 ( ref $e && $e->isa(__PACKAGE__)
    50 33        
23             ? $e->message : $e )
24             cmp
25             ( ref $f && $f->isa(__PACKAGE__)
26             ? $f->message : $f )
27 205     205   27660 };
  205         515  
  205         1420  
28              
29             # This is the base class of all exceptions
30              
31             sub new {
32 41     41 0 108 my $class = shift;
33 41         225 my $self = bless { _raised_arguments => [],
34             _shortmess => '',
35             _longmess => '',
36             }, $class;
37 41         257 $self->_raised_arguments(@_);
38 41         110 return $self;
39             }
40              
41             # base class has a passthrough message
42 0     0   0 sub _message_pattern { '%s' }
43              
44             sub throw {
45 41     41 1 93 my $self = shift;
46 41         186 $self->_raised_arguments(@_);
47 41         104 local $Carp::CarpInternal;
48 41         100 local $Carp::Internal;
49 41         126 $Carp::Internal{'Dancer'} ++;
50 41         96 $Carp::CarpInternal{'Dancer::Exception'} ++;
51 41         7764 $self->{_shortmess} = Carp::shortmess;
52 41         7936 $self->{_longmess} = Carp::longmess;
53 41         7971 die $self;
54             }
55              
56 0     0 1 0 sub rethrow { die $_[0] }
57              
58             sub message {
59 60     60 1 149 my ($self) = @_;
60 60         300 my $message_pattern = $self->_message_pattern;
61 60         134 my $message = sprintf($message_pattern, @{$self->_raised_arguments});
  60         158  
62 60         592 return $message;
63             }
64              
65             sub does {
66 5     5 1 1191 my $self = shift;
67 5         15 my $regexp = join('|', map { '^' . $_ . '$'; } @_);
  5         25  
68 5         23 (scalar grep { /$regexp/ } $self->get_composition) >= 1;
  18         147  
69             }
70              
71             sub get_composition {
72 6     6 1 37 my ($self) = @_;
73 6         15 my $class = ref($self);
74              
75 6         9 my ($_recurse_isa, %seen);
76             $_recurse_isa = sub {
77 34     34   60 my ($class) = @_;
78 34 100       96 $seen{$class}++
79             and return;
80              
81 205     205   86566 no strict 'refs';
  205         534  
  205         44559  
82 28         65 return $class, map { $_recurse_isa->($_) }
83 34         193 grep { /^Dancer::Exception::/ }
84 23         35 @{"${class}::ISA"};
  23         93  
85            
86 6         29 };
87 6         15 grep { s/^Dancer::Exception::// } $_recurse_isa->($class);
  23         82  
88             }
89              
90             sub _raised_arguments {
91 142     142   250 my $self = shift;
92 142 100       1716 @_ and $self->{_raised_arguments} = [ @_ ];
93 142         476 $self->{_raised_arguments};
94             }
95              
96             1;
97              
98             __END__