File Coverage

blib/lib/Mojo/Exception.pm
Criterion Covered Total %
statement 103 103 100.0
branch 46 50 92.0
condition 24 29 82.7
subroutine 18 18 100.0
pod 7 7 100.0
total 198 207 95.6


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