File Coverage

blib/lib/qbit/Exceptions.pm
Criterion Covered Total %
statement 39 103 37.8
branch 0 42 0.0
condition 0 33 0.0
subroutine 13 26 50.0
pod 0 11 0.0
total 52 215 24.1


line stmt bran cond sub pod time code
1              
2             =head1 Name
3              
4             qbit::Exceptions - qbit exceptions
5              
6             =cut
7              
8             package qbit::Exceptions;
9             $qbit::Exceptions::VERSION = '2.3';
10             =head1 Synopsis
11              
12             Usage:
13              
14             package Exception::Sample;
15             use base qw(Exception);
16              
17             package Sample;
18             use qbit;
19              
20             sub ttt {
21             throw 'Fatal error';
22              
23             # or
24             # throw Exception::Sample;
25              
26             # or
27             # throw Exception::Sample 'Some text describing problem';
28             };
29              
30             1;
31              
32             One more sample. Here we are not catching proper exception, and the program
33             stops. Finally blocks are always executed.
34              
35             package Exception::Sample;
36             use base qw(Exception);
37              
38             package Exception::OtherSample;
39             use base qw(Exception);
40              
41             package Sample;
42             use qbit;
43              
44             sub ttt {
45             my ($self) = @_;
46              
47             try {
48             print "try\n";
49             throw Exception::Sample 'Exception message';
50             }
51             catch Exception::OtherSample with {
52             print "catch\n";
53             }
54             finally {
55             print "finally\n";
56             };
57              
58             print "end\n";
59             }
60              
61             1;
62              
63             And one more code example. Here we have exception hierarchy. We are throwing
64             a complex exception but we can catch it with it's parents.
65              
66             package Exception::Basic;
67             use base qw(Exception);
68              
69             package Exception::Complex;
70             use base qw(Exception::Basic);
71              
72             package Sample;
73             use qbit;
74              
75             sub ttt {
76             my ($self) = @_;
77              
78             try {
79             print "try\n";
80             throw Exception::Complex 'Exception message';
81             }
82             catch Exception::Basic with {
83             print "catch\n";
84             }
85             finally {
86             print "finally\n";
87             };
88              
89             print "end\n";
90             }
91              
92             1;
93              
94             In catch and finally blocks you can access $@ that stores exception object.
95              
96             =cut
97              
98 8     8   45 use strict;
  8         14  
  8         273  
99 8     8   38 use warnings;
  8         14  
  8         380  
100              
101 8     8   37 use base qw(Exporter);
  8         14  
  8         1715  
102              
103             BEGIN {
104 8     8   16 our (@EXPORT, @EXPORT_OK);
105              
106 8         25 @EXPORT = qw(try catch with finally throw);
107 8         5419 @EXPORT_OK = @EXPORT;
108             }
109              
110             sub try(&;$) {
111 0     0 0   my ($sub, $catch) = @_;
112              
113 0           eval {$sub->()};
  0            
114              
115 0           my $cur_catch = $catch;
116 0   0       my $find_catch = !defined($catch) || $catch->[0] eq '::FINALLY::';
117              
118 0           my $first_exception = '';
119 0 0         if ($@) {
120 0 0 0       $@ = Exception::SysDie->new($@)
121             unless ref($@) && $@->isa('Exception');
122              
123 0           $first_exception = $@;
124              
125 0           while (defined($cur_catch)) {
126 0 0         last if $cur_catch->[0] eq '::FINALLY::';
127 0 0 0       if ($find_catch || $@->isa($cur_catch->[0])) {
128 0           $find_catch = 1;
129 0 0         if (ref($cur_catch->[1]) eq 'CODE') {
130 0           eval {$cur_catch->[1]($first_exception)};
  0            
131              
132 0 0         if ($@) {
133 0           $find_catch = 0;
134              
135 0 0 0       $@ = Exception::SysDie->new($@)
136             unless ref($@) && $@->isa('Exception');
137             }
138              
139 0           last;
140             } else {
141 0           $cur_catch = $cur_catch->[1];
142             }
143             } else {
144 0 0         $cur_catch = $cur_catch->[ref($cur_catch->[1]) eq 'CODE' ? 2 : 1];
145             }
146             }
147             }
148              
149 0 0 0       $cur_catch = $cur_catch->[ref($cur_catch->[1]) eq 'CODE' ? 2 : 1]
      0        
150             while ref($cur_catch) && defined($cur_catch) && $cur_catch->[0] ne '::FINALLY::';
151              
152 0 0 0       die("Expected semicolon after catch block (" . join(", ", (caller())[1, 2]) . ")\n")
153             if defined($cur_catch) && ref($cur_catch) ne 'ARRAY';
154              
155 0 0         $cur_catch->[1]($first_exception) if defined($cur_catch);
156              
157 0 0 0       die $@ if $@ && !$find_catch;
158             }
159              
160             sub catch(&;$) {
161 0     0 0   return [Exception => @_];
162             }
163              
164             sub with(&;$) {
165 0     0 0   return @_;
166             }
167              
168             sub finally(&;$) {
169 0 0   0 0   if (defined($_[1])) {die("Expected semicolon after finally block (" . join(", ", (caller())[1, 2]) . ")\n");}
  0            
170 0           return ['::FINALLY::' => @_];
171             }
172              
173             sub throw($) {
174 0     0 0   my ($exception) = @_;
175 0 0         $exception = Exception->new($exception) unless ref($exception);
176 0           die $exception;
177             }
178              
179             sub die_handler {
180 0 0   0 0   die @_ unless defined($^S); # Perl parser errors
181              
182 0           my ($exception) = @_;
183              
184 0 0         $exception = Exception::SysDie->new($exception) unless ref($exception);
185              
186 0           die $exception;
187             }
188              
189             package Exception;
190             $Exception::VERSION = '2.3';
191 8     8   65 use strict;
  8         13  
  8         230  
192 8     8   35 use warnings;
  8         12  
  8         524  
193 8     8   39 use overload '""' => sub {shift->as_string()};
  8     0   13  
  8         78  
  0         0  
194              
195 8     8   518 use Scalar::Util qw(blessed);
  8         11  
  8         5332  
196              
197             sub new {
198 0     0 0   my ($this, $text, %data) = @_;
199 0   0       my $class = ref($this) || $this;
200              
201 0 0         $text = '' if !defined $text;
202              
203 0           my @call_stack = ();
204 0           my $i = 0;
205              
206 0           while (1) {
207              
208             package DB;
209 0           $DB::VERSION = '2.3';
210 0           my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) =
211             caller($i);
212              
213 0 0         last if !defined($package);
214              
215 0 0 0       push(
216             @call_stack,
217             {
218             package => $package,
219             filename => $filename,
220             line => $line,
221             subroutine => $subroutine,
222             args => [@DB::args],
223             }
224             )
225             if $package ne 'qbit::Exceptions'
226             && $subroutine ne 'qbit::Exceptions::try';
227              
228 0           ++$i;
229             }
230              
231 0           my $caller = shift(@call_stack);
232             my $self = {
233             %data,
234             (
235             blessed($text) && $text->isa('Exception')
236             ? (text => $text->{'text'}, parent => $text)
237             : (text => $text)
238             ),
239             filename => $caller->{'filename'},
240             package => $caller->{'package'},
241 0 0 0       line => $caller->{'line'},
242             callstack => \@call_stack,
243             };
244              
245 0           bless $self, $class;
246 0           return $self;
247             }
248              
249             sub catch {
250 0     0 0   return \@_;
251             }
252              
253             sub throw {
254 0     0 0   qbit::Exceptions::throw(shift->new(@_));
255             }
256              
257             sub message {
258 0     0 0   return shift->{'text'};
259             }
260              
261             sub as_string {
262 0     0 0   my ($self) = @_;
263              
264             return
265             ref($self)
266             . ": $self->{'text'}\n"
267             . " Package: $self->{'package'}\n"
268             . " Filename: $self->{'filename'} (line $self->{'line'})\n"
269             . " CallStack:\n"
270             . ' '
271             . join("\n ",
272 0           map {$_->{'subroutine'} . "() called at '$_->{'filename'}' line $_->{'line'}"} @{$self->{'callstack'}})
  0            
273             . "\n"
274 0 0         . ($self->{'parent'} ? "\n$self->{'parent'}\n" : '');
275             }
276              
277             package Exception::SysDie;
278             $Exception::SysDie::VERSION = '2.3';
279 8     8   50 use base qw(Exception);
  8         19  
  8         4224  
280              
281 8     8   907 use strict;
  8         12  
  8         186  
282 8     8   35 use warnings;
  8         13  
  8         751  
283              
284             sub new {
285 0     0     my ($self, $text) = @_;
286              
287 0           chomp($text);
288              
289 0           return $self->SUPER::new($text);
290             }
291              
292             package Exception::BadArguments;
293             $Exception::BadArguments::VERSION = '2.3';
294 8     8   40 use base qw(Exception);
  8         10  
  8         767  
295              
296             package Exception::Denied;
297             $Exception::Denied::VERSION = '2.3';
298 8     8   40 use base qw(Exception);
  8         13  
  8         542  
299              
300             1;