File Coverage

blib/lib/Class/Throwable.pm
Criterion Covered Total %
statement 108 108 100.0
branch 49 50 98.0
condition 14 22 63.6
subroutine 19 19 100.0
pod 10 10 100.0
total 200 209 95.6


line stmt bran cond sub pod time code
1              
2             package Class::Throwable;
3              
4 6     6   102285 use strict;
  6         11  
  6         298  
5 6     6   32 use warnings;
  6         8  
  6         312  
6              
7             our $VERSION = '0.13';
8              
9 6     6   39 use Scalar::Util qw(blessed);
  6         14  
  6         1728  
10              
11             our $DEFAULT_VERBOSITY = 1;
12              
13             my %VERBOSITY;
14              
15             # allow the creation of exceptions
16             # without having to actually create
17             # a package for them
18             sub import {
19 15     15   4427 my $class = shift;
20 15 100       74 return unless @_;
21 13 100       51 if ($_[0] eq 'VERBOSE') {
    100          
22 5 100       19 (defined $_[1]) || die "You must specify a level of verbosity with Class::Throwable\n";
23             # make sure its not a refernce
24 4   33     19 $class = ref($class) || $class;
25             # and then store it
26 4         24 $VERBOSITY{$class} = $_[1];
27             }
28             elsif ($_[0] eq 'retrofit') {
29 3 100       21 (defined $_[1]) || die "You must specify a module for Class::Throwable to retrofit\n";
30 2         2 my $package = $_[1];
31 2     1   6 my $retrofitter = sub { Class::Throwable->throw(@_) };
  1         15  
32 2 100 66     10 $retrofitter = $_[2] if defined $_[2] && ref($_[2]) eq 'CODE';
33 2         4 eval {
34 6     6   31 no strict 'refs';
  6         9  
  6         973  
35 2         3 *{"${package}::die"} = $retrofitter;
  2         19  
36             };
37 2 50       18 die "Could not retrofit '$package' with Class::Throwable : $@\n" if $@;
38             }
39             else {
40 5 100       17 ($class eq 'Class::Throwable')
41             || die "Inline Exceptions can only be created with Class::Throwable\n";
42 4         6 my @exceptions = @_;
43 4         10 foreach my $exception (@exceptions) {
44 7 100       29 next unless $exception;
45 4         322 eval "package ${exception}; \@${exception}::ISA = qw(Class::Throwable);";
46 4 100       58 die "An error occured while constructing Class::Throwable exception ($exception) : $@\n" if $@;
47             }
48             }
49             }
50              
51             # overload the stringify operation
52 6     6   7927 use overload q|""| => "toString", fallback => 1;
  6         5166  
  6         39  
53              
54             # a class method to set the verbosity
55             # of inline exceptions
56             sub setVerbosity {
57 3     3 1 1755 my ($class, $verbosity) = @_;
58 3 100       592 (!ref($class)) || die "setVerbosity is a class method only, it cannot be used on an instance\n";
59 2 100       13 (defined($verbosity)) || die "You must specify a level of verbosity with Class::Throwable\n";
60 1         6 $VERBOSITY{$class} = $verbosity;
61             }
62              
63             # create an exception without
64             # any stack trace information
65             sub new {
66 2     2 1 332 my ($class, $message, $sub_exception) = @_;
67 2         5 my $exception = {};
68 2   33     18 bless($exception, ref($class) || $class);
69 2         7 $exception->_init($message, $sub_exception);
70 2         6 return $exception;
71             }
72              
73             # throw an exception with this
74             sub throw {
75 19     19 1 3700 my ($class, $message, $sub_exception) = @_;
76             # if i am being re-thrown, then just die with the class
77 19 100 66     115 if (blessed($class) && $class->isa("Class::Throwable")) {
78             # first make sure we have a stack trace, if we
79             # don't then we were likely created with 'new'
80             # and not 'throw', and so we need to gather the
81             # stack information from here
82 2 100       8 $class->_initStackTrace() unless my @s = $class->getStackTrace();
83 2         10 die $class;
84             }
85             # otherwise i am being thrown for the first time so
86             # create a new 'me' and then die after i am blessed
87 17         29 my $exception = {};
88 17         42 bless($exception, $class);
89 17         63 $exception->_init($message, $sub_exception);
90             # init our stack trace
91 17         53 $exception->_initStackTrace();
92 17         80 die $exception;
93             }
94              
95             ## initializers
96              
97             sub _init {
98 19     19   31 my ($self, $message, $sub_exception) = @_;
99             # the sub-exception is another exception
100             # which has already been caught, and is
101             # the cause of this exception being thrown
102             # so we dont want to loose that information
103             # so we store it here
104             # NOTE:
105             # we do not enforce the type of exception here
106             # becuase it is possible this was thrown by
107             # perl itself and therefore could be a string
108 19         364 $self->{sub_exception} = $sub_exception;
109 19   66     84 $self->{message} = $message || "An ". ref($self) . " Exception has been thrown";
110 19         46 $self->{stack_trace} = [];
111             }
112              
113             sub _initStackTrace {
114 18     18   26 my ($self) = @_;
115 18         23 my @stack_trace;
116             # these are the 10 values returned from caller():
117             # $package, $filename, $line, $subroutine, $hasargs,
118             # $wantarray, $evaltext, $is_require, $hints, $bitmask
119             # we do not bother to capture the last two as they are
120             # subject to change and not meant for internal use
121             {
122 18         22 package DB;
123 18         25 my $i = 1;
124 18         24 my @c;
125 18         221 while (@c = caller($i++)) {
126             # dont bother to get our caller
127 51 100       274 next if $c[3] =~ /Class\:\:Throwable\:\:throw/;
128 33         231 push @stack_trace, [ @c[0 .. 7] ];
129             }
130             }
131 18         49 $self->{stack_trace} = \@stack_trace;
132             }
133              
134             # accessors
135              
136             sub hasSubException {
137 15     15 1 2378 my ($self) = @_;
138 15 100       66 return defined $self->{sub_exception} ? 1 : 0;
139             }
140              
141             sub getSubException {
142 8     8 1 11 my ($self) = @_;
143 8         23 return $self->{sub_exception};
144             }
145              
146             sub getMessage {
147 9     9 1 5401 my ($self) = @_;
148 9         54 return $self->{"message"};
149             }
150              
151             sub getStackTrace {
152 6     6 1 497 my ($self) = @_;
153             return wantarray ?
154 6 100       31 @{$self->{stack_trace}}
  4         37  
155             :
156             $self->{stack_trace};
157             }
158              
159             sub stackTraceToString {
160 12     12 1 40 my ($self, $depth) = @_;
161 12         14 my @output;
162 12   100     31 $depth ||= 1;
163 12         45 my $indent = " " x $depth;
164 12         25 foreach my $frame (@{$self->{stack_trace}}) {
  12         33  
165 21         33 my ($package, $filename, $line, $subroutine) = @{$frame};
  21         76  
166 21 100       62 $subroutine = "${package}::${subroutine}" if ($subroutine eq '(eval)');
167 21         81 push @output, "$indent|--[ $subroutine called in $filename line $line ]"
168             }
169 12         71 return (join "\n" => @output);
170             }
171              
172             sub toString {
173 16     16 1 1438 my ($self, $verbosity, $depth) = @_;
174 16 100       46 unless (defined $verbosity) {
175 9 100       33 if (exists $VERBOSITY{ref($self)}) {
176 7         546 $verbosity = $VERBOSITY{ref($self)};
177             }
178             else {
179 2         3 $verbosity = $DEFAULT_VERBOSITY;
180             }
181             }
182             # get out of here quick if
183             # exception handling is off
184 16 100       52 return "" if $verbosity <= 0;
185             # otherwise construct our output
186 15         56 my $output = ref($self) . " : " . $self->{"message"};
187             # if we VERBOSE is set to 1, then
188             # we just return the message
189 15 100       58 return $output if $verbosity <= 1;
190 11   100     42 $depth ||= 1;
191 11 100       27 if ($depth > 1) {
192 4         12 $output = (" " x ($depth - 1)) . "+ $output";
193 4         7 $depth++;
194             }
195             # however, if VERBOSE is 2 or above
196             # then we include the stack trace
197 11         33 $output .= "\n" . (join "\n" => $self->stackTraceToString($depth)) . "\n";
198             # now we gather any sub-exceptions too
199 11 100       37 if ($self->hasSubException()) {
200 5         14 my $e = $self->getSubException();
201             # make sure the sub-exception is one
202             # of our objects, and ....
203 5 100 66     47 if (blessed($e) && $e->isa("Class::Throwable")) {
204             # deal with it appropriately
205 4         30 $output .= $e->toString($verbosity, $depth + 1);
206             }
207             # otherwise ...
208             else {
209             # just stringify it
210 1         4 $output .= (" " x ($depth)) . "+ $e";
211             }
212             }
213 11         55 return $output;
214             }
215              
216             sub stringValue {
217 6     6 1 562 my ($self) = @_;
218 6         19 return overload::StrVal($self);
219             }
220              
221             1;
222              
223             __END__