File Coverage

blib/lib/Mojo/Exception.pm
Criterion Covered Total %
statement 105 105 100.0
branch 47 52 90.3
condition 22 28 78.5
subroutine 19 19 100.0
pod 7 7 100.0
total 200 211 94.7


line stmt bran cond sub pod time code
1             package Mojo::Exception;
2 62     62   63854 use Mojo::Base -base;
  62         131  
  62         426  
3 62     62   475 use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
  62     101   156  
  62     46   767  
  53         230  
  109         6313  
4              
5 62     62   6203 use Exporter 'import';
  62         143  
  62         2053  
6 62     62   452 use Mojo::Util 'decode';
  62         139  
  62         3288  
7 62     62   453 use Scalar::Util 'blessed';
  62         160  
  62         106612  
8              
9             has [qw(frames line lines_after lines_before)] => sub { [] };
10             has message => 'Exception!';
11             has verbose => sub { $ENV{MOJO_EXCEPTION_VERBOSE} };
12              
13             our @EXPORT_OK = qw(check raise);
14              
15             sub check {
16 16 100   16 1 3692 my ($err, @spec) = @_ % 2 ? @_ : ($@, @_);
17              
18             # Finally (search backwards since it is usually at the end)
19 16         28 my $guard;
20 16         55 for (my $i = $#spec - 1; $i >= 0; $i -= 2) {
21 29 100 50     95 ($guard = Mojo::Exception::_Guard->new(finally => $spec[$i + 1])) and last
22             if $spec[$i] eq 'finally';
23             }
24              
25 16 100       88 return undef unless $err;
26              
27 14         21 my ($default, $handler);
28 14         71 my ($is_obj, $str) = (!!blessed($err), "$err");
29 14         38 CHECK: for (my $i = 0; $i < @spec; $i += 2) {
30 26         56 my ($checks, $cb) = @spec[$i, $i + 1];
31              
32 26 100 50     64 ($default = $cb) and next if $checks eq 'default';
33              
34 20 100       47 for my $c (ref $checks eq 'ARRAY' ? @$checks : $checks) {
35 22         34 my $is_re = !!ref $c;
36 22 100 50     111 ($handler = $cb) and last CHECK if $is_obj && !$is_re && $err->isa($c);
      100        
      100        
37 17 100 50     106 ($handler = $cb) and last CHECK if $is_re && $str =~ $c;
      100        
38             }
39             }
40              
41             # Rethrow if no handler could be found
42 14 100 100     55 die $err unless $handler ||= $default;
43 12         36 $handler->($_) for $err;
44              
45 11         59 return 1;
46             }
47              
48             sub inspect {
49 97     97 1 1162 my ($self, @sources) = @_;
50              
51 97 100       198 return $self if @{$self->line};
  97         315  
52              
53             # Extract file and line from message
54 84         184 my @files;
55 84         449 my $msg = $self->message;
56 84         1395 unshift @files, [$1, $2] while $msg =~ /at\s+(.+?)\s+line\s+(\d+)/g;
57              
58             # Extract file and line from stack trace
59 84 100       297 if (my $zero = $self->frames->[0]) { push @files, [$zero->[1], $zero->[2]] }
  57         212  
60              
61             # Search for context in files
62 84         254 for my $file (@files) {
63 97 100 66     5025 next unless -r $file->[0] && open my $handle, '<', $file->[0];
64 57         43240 $self->_context($file->[1], [[<$handle>]]);
65 57         8077 return $self;
66             }
67              
68             # Search for context in sources
69 27 100       146 $self->_context($files[-1][1], [map { [split "\n"] } @sources]) if @sources;
  36         272  
70              
71 27         205 return $self;
72             }
73              
74             sub new {
75 131 100   131 1 3243 defined $_[1] ? shift->SUPER::new(message => shift) : shift->SUPER::new;
76             }
77              
78             sub raise {
79 5 100   5 1 1637 my ($class, $err) = @_ > 1 ? (@_) : (__PACKAGE__, shift);
80              
81 5 100       60 if (!$class->can('new')) {
    100          
82 1 50   1   121 die $@ unless eval "package $class; use Mojo::Base 'Mojo::Exception'; 1";
  1         11  
  1         2  
  1         6  
83             }
84             elsif (!$class->isa(__PACKAGE__)) {
85 1         9 die "$class is not a Mojo::Exception subclass";
86             }
87              
88 4         17 CORE::die $class->new($err)->trace;
89             }
90              
91             sub to_string {
92 109     109 1 200 my $self = shift;
93              
94 109         312 my $str = $self->message;
95              
96 109         309 my $frames = $self->frames;
97 109 100       530 if ($str !~ /\n$/) {
98 31 100       99 $str .= @$frames ? " at $frames->[0][1] line $frames->[0][2].\n" : "\n";
99             }
100 109 100       300 return $str unless $self->verbose;
101              
102 31         94 my $line = $self->line;
103 31 50       84 if (@$line) {
104 31         101 $str .= "Context:\n";
105 31         100 $str .= " $_->[0]: $_->[1]\n" for @{$self->lines_before};
  31         112  
106 31         122 $str .= " $line->[0]: $line->[1]\n";
107 31         58 $str .= " $_->[0]: $_->[1]\n" for @{$self->lines_after};
  31         77  
108             }
109              
110 31 50       96 if (my $max = @$frames) {
111 31         80 $str .= "Traceback (most recent call first):\n";
112 31         1539 $str .= qq{ File "$_->[1]", line $_->[2], in "$_->[0]"\n} for @$frames;
113             }
114              
115 31         325 return $str;
116             }
117              
118 3     3 1 623 sub throw { CORE::die shift->new(shift)->trace }
119              
120             sub trace {
121 101   100 101 1 533 my ($self, $start) = (shift, shift // 1);
122 101         186 my @frames;
123 101         1380 while (my @trace = caller($start++)) { push @frames, \@trace }
  3648         28238  
124 101         541 return $self->frames(\@frames);
125             }
126              
127             sub _append {
128 662     662   1284 my ($stack, $line) = @_;
129 662   66     1344 $line = decode('UTF-8', $line) // $line;
130 662         1260 chomp $line;
131 662         1801 push @$stack, $line;
132             }
133              
134             sub _context {
135 75     75   304 my ($self, $num, $sources) = @_;
136              
137             # Line
138 75 50       414 return unless defined $sources->[0][$num - 1];
139 75         426 $self->line([$num]);
140 75         401 _append($self->line, $_->[$num - 1]) for @$sources;
141              
142             # Before
143 75         257 for my $i (2 .. 6) {
144 307 100       739 last if ((my $previous = $num - $i) < 0);
145 277         390 unshift @{$self->lines_before}, [$previous + 1];
  277         674  
146 277         800 _append($self->lines_before->[0], $_->[$previous]) for @$sources;
147             }
148              
149             # After
150 75         220 for my $i (0 .. 4) {
151 375 50       780 next if ((my $next = $num + $i) < 0);
152 375 100       778 next unless defined $sources->[0][$next];
153 264         371 push @{$self->lines_after}, [$next + 1];
  264         567  
154 264         728 _append($self->lines_after->[-1], $_->[$next]) for @$sources;
155             }
156             }
157              
158             package Mojo::Exception::_Guard;
159 62     62   556 use Mojo::Base -base;
  62         146  
  62         346  
160              
161 3     3   14 sub DESTROY { shift->{finally}->() }
162              
163             1;
164              
165             =encoding utf8
166              
167             =head1 NAME
168              
169             Mojo::Exception - Exception base class
170              
171             =head1 SYNOPSIS
172              
173             # Create exception classes
174             package MyApp::X::Foo {
175             use Mojo::Base 'Mojo::Exception';
176             }
177             package MyApp::X::Bar {
178             use Mojo::Base 'Mojo::Exception';
179             }
180              
181             # Throw exceptions and handle them gracefully
182             use Mojo::Exception 'check';
183             eval {
184             MyApp::X::Foo->throw('Something went wrong!');
185             };
186             check(
187             'MyApp::X::Foo' => sub { say "Foo: $_" },
188             'MyApp::X::Bar' => sub { say "Bar: $_" }
189             );
190              
191             # Generate exception classes on demand
192             use Mojo::Exception qw(check raise);
193             eval {
194             raise 'MyApp::X::Name', 'The name Minion is already taken';
195             };
196             check(
197             'MyApp::X::Name' => sub { say "Name error: $_" },
198             default => sub { say "Error: $_" }
199             );
200              
201             =head1 DESCRIPTION
202              
203             L is a container for exceptions with context information.
204              
205             =head1 FUNCTIONS
206              
207             L implements the following functions, which can be imported
208             individually.
209              
210             =head2 check
211              
212             my $bool = check 'MyApp::X::Foo' => sub {...};
213             my $bool = check $err, 'MyApp::X::Foo' => sub {...};
214              
215             Process exceptions by dispatching them to handlers with one or more matching
216             conditions. Exceptions that could not be handled will be rethrown automatically.
217             By default C<$@> will be used as exception source, so C needs to be
218             called right after C. Note that this function is B and might
219             change without warning!
220              
221             # Handle various types of exceptions
222             eval {
223             dangerous_code();
224             };
225             check(
226             'MyApp::X::Foo' => sub { say "Foo: $_" },
227             qr/^Could not open/ => sub { say "Open error: $_" },
228             default => sub { say "Something went wrong: $_" },
229             finally => sub { say 'Dangerous code is done' }
230             );
231              
232             Matching conditions can be class names for ISA checks on exception objects, or
233             regular expressions to match string exceptions and stringified exception
234             objects. The matching exception will be the first argument passed to the
235             callback, and is also available as C<$_>.
236              
237             # Catch MyApp::X::Foo object or a specific string exception
238             eval {
239             dangerous_code();
240             };
241             check(
242             'MyApp::X::Foo' => sub { say "Foo: $_" },
243             qr/^Could not open/ => sub { say "Open error: $_" }
244             );
245              
246             An array reference can be used to share the same handler with multiple
247             conditions, of which only one needs to match. And since exception handlers are
248             just callbacks, they can also throw their own exceptions.
249              
250             # Handle MyApp::X::Foo and MyApp::X::Bar the same
251             eval {
252             dangerous_code();
253             };
254             check(
255             ['MyApp::X::Foo', 'MyApp::X::Bar'] => sub { die "Foo/Bar: $_" }
256             );
257              
258             There are currently two keywords you can use to set special handlers. The
259             C handler is used when no other handler matched. And the C
260             handler runs always, it does not affect normal handlers and even runs if the
261             exception was rethrown or if there was no exception to be handled at all.
262              
263             # Use "default" to catch everything
264             eval {
265             dangerous_code();
266             };
267             check(
268             default => sub { say "Error: $_" },
269             finally => sub { say 'Dangerous code is done' }
270             );
271              
272             =head2 raise
273              
274             raise 'Something went wrong!';
275             raise 'MyApp::X::Foo', 'Something went wrong!';
276              
277             Raise a L, if the class does not exist yet (classes are checked
278             for a C method), one is created as a L subclass on demand.
279             Note that this function is B and might change without warning!
280              
281             =head1 ATTRIBUTES
282              
283             L implements the following attributes.
284              
285             =head2 frames
286              
287             my $frames = $e->frames;
288             $e = $e->frames([$frame1, $frame2]);
289              
290             Stack trace if available.
291              
292             # Extract information from the last frame
293             my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext,
294             $is_require, $hints, $bitmask, $hinthash) = @{$e->frames->[-1]};
295              
296             =head2 line
297              
298             my $line = $e->line;
299             $e = $e->line([3, 'die;']);
300              
301             The line where the exception occurred if available.
302              
303             =head2 lines_after
304              
305             my $lines = $e->lines_after;
306             $e = $e->lines_after([[4, 'say $foo;'], [5, 'say $bar;']]);
307              
308             Lines after the line where the exception occurred if available.
309              
310             =head2 lines_before
311              
312             my $lines = $e->lines_before;
313             $e = $e->lines_before([[1, 'my $foo = 23;'], [2, 'my $bar = 24;']]);
314              
315             Lines before the line where the exception occurred if available.
316              
317             =head2 message
318              
319             my $msg = $e->message;
320             $e = $e->message('Died at test.pl line 3.');
321              
322             Exception message, defaults to C.
323              
324             =head2 verbose
325              
326             my $bool = $e->verbose;
327             $e = $e->verbose($bool);
328              
329             Show more information with L, such as L, defaults to
330             the value of the C environment variable.
331              
332             =head1 METHODS
333              
334             L inherits all methods from L and implements the
335             following new ones.
336              
337             =head2 inspect
338              
339             $e = $e->inspect;
340             $e = $e->inspect($source1, $source2);
341              
342             Inspect L, L and optional additional sources to fill
343             L, L and L with context information.
344              
345             =head2 new
346              
347             my $e = Mojo::Exception->new;
348             my $e = Mojo::Exception->new('Died at test.pl line 3.');
349              
350             Construct a new L object and assign L if necessary.
351              
352             =head2 to_string
353              
354             my $str = $e->to_string;
355              
356             Render exception. Note that the output format may change as more features are
357             added, only the error message at the beginning is guaranteed not to be modified
358             to allow regex matching.
359              
360             =head2 throw
361              
362             Mojo::Exception->throw('Something went wrong!');
363              
364             Throw exception from the current execution context.
365              
366             # Longer version
367             die Mojo::Exception->new('Something went wrong!')->trace;
368              
369             =head2 trace
370              
371             $e = $e->trace;
372             $e = $e->trace($skip);
373              
374             Generate stack trace and store all L, defaults to skipping C<1> call
375             frame.
376              
377             # Skip 3 call frames
378             $e->trace(3);
379              
380             # Skip no call frames
381             $e->trace(0);
382              
383             =head1 OPERATORS
384              
385             L overloads the following operators.
386              
387             =head2 bool
388              
389             my $bool = !!$e;
390              
391             Always true.
392              
393             =head2 stringify
394              
395             my $str = "$e";
396              
397             Alias for L.
398              
399             =head1 SEE ALSO
400              
401             L, L, L.
402              
403             =cut