Commit | Line | Data |
0b09a93a |
1 | package autodie::exception; |
2 | use 5.008; |
3 | use strict; |
4 | use warnings; |
5 | use Carp qw(croak); |
6 | |
7 | our $DEBUG = 0; |
8 | |
9 | use overload |
10 | q{""} => "stringify" |
11 | ; |
12 | |
13 | # Overload smart-match only if we're using 5.10 |
14 | |
15 | use if ($] >= 5.010), overload => '~~' => "matches"; |
16 | |
7840a289 |
17 | our $VERSION = '2.06_01'; |
0b09a93a |
18 | |
19 | my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. |
20 | |
21 | =head1 NAME |
22 | |
23 | autodie::exception - Exceptions from autodying functions. |
24 | |
25 | =head1 SYNOPSIS |
26 | |
27 | eval { |
28 | use autodie; |
29 | |
30 | open(my $fh, '<', 'some_file.txt'); |
31 | |
32 | ... |
33 | }; |
34 | |
35 | if (my $E = $@) { |
36 | say "Ooops! ",$E->caller," had problems: $@"; |
37 | } |
38 | |
39 | |
40 | =head1 DESCRIPTION |
41 | |
42 | When an L<autodie> enabled function fails, it generates an |
43 | C<autodie::exception> object. This can be interrogated to |
44 | determine further information about the error that occurred. |
45 | |
46 | This document is broken into two sections; those methods that |
47 | are most useful to the end-developer, and those methods for |
48 | anyone wishing to subclass or get very familiar with |
49 | C<autodie::exception>. |
50 | |
51 | =head2 Common Methods |
52 | |
53 | These methods are intended to be used in the everyday dealing |
54 | of exceptions. |
55 | |
56 | The following assume that the error has been copied into |
57 | a separate scalar: |
58 | |
59 | if ($E = $@) { |
60 | ... |
61 | } |
62 | |
63 | This is not required, but is recommended in case any code |
64 | is called which may reset or alter C<$@>. |
65 | |
66 | =cut |
67 | |
68 | =head3 args |
69 | |
70 | my $array_ref = $E->args; |
71 | |
72 | Provides a reference to the arguments passed to the subroutine |
73 | that died. |
74 | |
75 | =cut |
76 | |
77 | sub args { return $_[0]->{$PACKAGE}{args}; } |
78 | |
79 | =head3 function |
80 | |
81 | my $sub = $E->function; |
82 | |
83 | The subroutine (including package) that threw the exception. |
84 | |
85 | =cut |
86 | |
87 | sub function { return $_[0]->{$PACKAGE}{function}; } |
88 | |
89 | =head3 file |
90 | |
91 | my $file = $E->file; |
92 | |
93 | The file in which the error occurred (eg, C<myscript.pl> or |
94 | C<MyTest.pm>). |
95 | |
96 | =cut |
97 | |
98 | sub file { return $_[0]->{$PACKAGE}{file}; } |
99 | |
100 | =head3 package |
101 | |
102 | my $package = $E->package; |
103 | |
104 | The package from which the exceptional subroutine was called. |
105 | |
106 | =cut |
107 | |
108 | sub package { return $_[0]->{$PACKAGE}{package}; } |
109 | |
110 | =head3 caller |
111 | |
112 | my $caller = $E->caller; |
113 | |
114 | The subroutine that I<called> the exceptional code. |
115 | |
116 | =cut |
117 | |
118 | sub caller { return $_[0]->{$PACKAGE}{caller}; } |
119 | |
120 | =head3 line |
121 | |
122 | my $line = $E->line; |
123 | |
124 | The line in C<< $E->file >> where the exceptional code was called. |
125 | |
126 | =cut |
127 | |
128 | sub line { return $_[0]->{$PACKAGE}{line}; } |
129 | |
eb8d423f |
130 | =head3 context |
131 | |
132 | my $context = $E->context; |
133 | |
134 | The context in which the subroutine was called. This can be |
135 | 'list', 'scalar', or undefined (unknown). It will never be 'void', as |
136 | C<autodie> always captures the return value in one way or another. |
137 | |
138 | =cut |
139 | |
140 | sub context { return $_[0]->{$PACKAGE}{context} } |
141 | |
142 | =head3 return |
143 | |
144 | my $return_value = $E->return; |
145 | |
146 | The value(s) returned by the failed subroutine. When the subroutine |
147 | was called in a list context, this will always be a reference to an |
148 | array containing the results. When the subroutine was called in |
149 | a scalar context, this will be the actual scalar returned. |
150 | |
151 | =cut |
152 | |
153 | sub return { return $_[0]->{$PACKAGE}{return} } |
154 | |
0b09a93a |
155 | =head3 errno |
156 | |
157 | my $errno = $E->errno; |
158 | |
159 | The value of C<$!> at the time when the exception occurred. |
160 | |
161 | B<NOTE>: This method will leave the main C<autodie::exception> class |
162 | and become part of a role in the future. You should only call |
163 | C<errno> for exceptions where C<$!> would reasonably have been |
164 | set on failure. |
165 | |
166 | =cut |
167 | |
168 | # TODO: Make errno part of a role. It doesn't make sense for |
169 | # everything. |
170 | |
171 | sub errno { return $_[0]->{$PACKAGE}{errno}; } |
172 | |
7840a289 |
173 | =head3 eval_error |
174 | |
175 | my $old_eval_error = $E->eval_error; |
176 | |
177 | The contents of C<$@> immediately after autodie triggered an |
178 | exception. This may be useful when dealing with modules such |
179 | as L<Text::Balanced> that set (but do not throw) C<$@> on error. |
180 | |
181 | =cut |
182 | |
183 | sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; } |
184 | |
0b09a93a |
185 | =head3 matches |
186 | |
187 | if ( $e->matches('open') ) { ... } |
188 | |
189 | if ( $e ~~ 'open' ) { ... } |
190 | |
191 | C<matches> is used to determine whether a |
192 | given exception matches a particular role. On Perl 5.10, |
193 | using smart-match (C<~~>) with an C<autodie::exception> object |
194 | will use C<matches> underneath. |
195 | |
196 | An exception is considered to match a string if: |
197 | |
198 | =over 4 |
199 | |
200 | =item * |
201 | |
202 | For a string not starting with a colon, the string exactly matches the |
203 | package and subroutine that threw the exception. For example, |
204 | C<MyModule::log>. If the string does not contain a package name, |
205 | C<CORE::> is assumed. |
206 | |
207 | =item * |
208 | |
209 | For a string that does start with a colon, if the subroutine |
210 | throwing the exception I<does> that behaviour. For example, the |
211 | C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>. |
212 | |
213 | See L<autodie/CATEGORIES> for futher information. |
214 | |
215 | =back |
216 | |
217 | =cut |
218 | |
219 | { |
220 | my (%cache); |
221 | |
222 | sub matches { |
223 | my ($this, $that) = @_; |
224 | |
9b657a62 |
225 | # TODO - Handle references |
0b09a93a |
226 | croak "UNIMPLEMENTED" if ref $that; |
227 | |
228 | my $sub = $this->function; |
229 | |
230 | if ($DEBUG) { |
231 | my $sub2 = $this->function; |
232 | warn "Smart-matching $that against $sub / $sub2\n"; |
233 | } |
234 | |
235 | # Direct subname match. |
236 | return 1 if $that eq $sub; |
237 | return 1 if $that !~ /:/ and "CORE::$that" eq $sub; |
238 | return 0 if $that !~ /^:/; |
239 | |
240 | # Cached match / check tags. |
241 | require Fatal; |
242 | |
243 | if (exists $cache{$sub}{$that}) { |
244 | return $cache{$sub}{$that}; |
245 | } |
246 | |
247 | # This rather awful looking line checks to see if our sub is in the |
248 | # list of expanded tags, caches it, and returns the result. |
249 | |
250 | return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) }; |
251 | } |
252 | } |
253 | |
254 | # This exists primarily so that child classes can override or |
255 | # augment it if they wish. |
256 | |
257 | sub _expand_tag { |
258 | my ($this, @args) = @_; |
259 | |
260 | return Fatal->_expand_tag(@args); |
261 | } |
262 | |
263 | =head2 Advanced methods |
264 | |
265 | The following methods, while usable from anywhere, are primarily |
266 | intended for developers wishing to subclass C<autodie::exception>, |
267 | write code that registers custom error messages, or otherwise |
268 | work closely with the C<autodie::exception> model. |
269 | |
270 | =cut |
271 | |
272 | # The table below records customer formatters. |
273 | # TODO - Should this be a package var instead? |
274 | # TODO - Should these be in a completely different file, or |
275 | # perhaps loaded on demand? Most formatters will never |
276 | # get used in most programs. |
277 | |
278 | my %formatter_of = ( |
279 | 'CORE::close' => \&_format_close, |
280 | 'CORE::open' => \&_format_open, |
281 | 'CORE::dbmopen' => \&_format_dbmopen, |
282 | 'CORE::flock' => \&_format_flock, |
283 | ); |
284 | |
285 | # TODO: Our tests only check LOCK_EX | LOCK_NB is properly |
286 | # formatted. Try other combinations and ensure they work |
287 | # correctly. |
288 | |
289 | sub _format_flock { |
290 | my ($this) = @_; |
291 | |
292 | require Fcntl; |
293 | |
294 | my $filehandle = $this->args->[0]; |
295 | my $raw_mode = $this->args->[1]; |
296 | |
297 | my $mode_type; |
298 | my $lock_unlock; |
299 | |
300 | if ($raw_mode & Fcntl::LOCK_EX() ) { |
301 | $lock_unlock = "lock"; |
302 | $mode_type = "for exclusive access"; |
303 | } |
304 | elsif ($raw_mode & Fcntl::LOCK_SH() ) { |
305 | $lock_unlock = "lock"; |
306 | $mode_type = "for shared access"; |
307 | } |
308 | elsif ($raw_mode & Fcntl::LOCK_UN() ) { |
309 | $lock_unlock = "unlock"; |
310 | $mode_type = ""; |
311 | } |
312 | else { |
313 | # I've got no idea what they're trying to do. |
314 | $lock_unlock = "lock"; |
315 | $mode_type = "with mode $raw_mode"; |
316 | } |
317 | |
318 | my $cooked_filehandle; |
319 | |
320 | if ($filehandle and not ref $filehandle) { |
321 | |
322 | # A package filehandle with a name! |
323 | |
324 | $cooked_filehandle = " $filehandle"; |
325 | } |
326 | else { |
327 | # Otherwise we have a scalar filehandle. |
328 | |
329 | $cooked_filehandle = ''; |
330 | |
331 | } |
332 | |
333 | local $! = $this->errno; |
334 | |
335 | return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!"; |
336 | |
337 | } |
338 | |
339 | # Default formatter for CORE::dbmopen |
340 | sub _format_dbmopen { |
341 | my ($this) = @_; |
342 | my @args = @{$this->args}; |
343 | |
344 | # TODO: Presently, $args flattens out the (usually empty) hash |
345 | # which is passed as the first argument to dbmopen. This is |
346 | # a bug in our args handling code (taking a reference to it would |
347 | # be better), but for the moment we'll just examine the end of |
348 | # our arguments list for message formatting. |
349 | |
350 | my $mode = $args[-1]; |
351 | my $file = $args[-2]; |
352 | |
353 | # If we have a mask, then display it in octal, not decimal. |
354 | # We don't do this if it already looks octalish, or doesn't |
355 | # look like a number. |
356 | |
357 | if ($mode =~ /^[^\D0]\d+$/) { |
358 | $mode = sprintf("0%lo", $mode); |
359 | }; |
360 | |
361 | local $! = $this->errno; |
362 | |
363 | return "Can't dbmopen(%hash, '$file', $mode): '$!'"; |
364 | } |
365 | |
366 | # Default formatter for CORE::close |
367 | |
368 | sub _format_close { |
369 | my ($this) = @_; |
370 | my $close_arg = $this->args->[0]; |
371 | |
372 | local $! = $this->errno; |
373 | |
374 | # If we've got an old-style filehandle, mention it. |
375 | if ($close_arg and not ref $close_arg) { |
376 | return "Can't close filehandle '$close_arg': '$!'"; |
377 | } |
378 | |
379 | # TODO - This will probably produce an ugly error. Test and fix. |
380 | return "Can't close($close_arg) filehandle: '$!'"; |
381 | |
382 | } |
383 | |
384 | # Default formatter for CORE::open |
385 | |
386 | use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'"; |
387 | |
388 | sub _format_open_with_mode { |
389 | my ($this, $mode, $file, $error) = @_; |
390 | |
391 | my $wordy_mode; |
392 | |
393 | if ($mode eq '<') { $wordy_mode = 'reading'; } |
394 | elsif ($mode eq '>') { $wordy_mode = 'writing'; } |
395 | elsif ($mode eq '>>') { $wordy_mode = 'appending'; } |
396 | |
397 | return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode; |
398 | |
399 | Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'."); |
400 | |
401 | } |
402 | |
403 | sub _format_open { |
404 | my ($this) = @_; |
405 | |
406 | my @open_args = @{$this->args}; |
407 | |
408 | # Use the default formatter for single-arg and many-arg open |
409 | if (@open_args <= 1 or @open_args >= 4) { |
410 | return $this->format_default; |
411 | } |
412 | |
413 | # For two arg open, we have to extract the mode |
414 | if (@open_args == 2) { |
415 | my ($fh, $file) = @open_args; |
416 | |
417 | if (ref($fh) eq "GLOB") { |
418 | $fh = '$fh'; |
419 | } |
420 | |
421 | my ($mode) = $file =~ m{ |
422 | ^\s* # Spaces before mode |
423 | ( |
424 | (?> # Non-backtracking subexp. |
425 | < # Reading |
426 | |>>? # Writing/appending |
427 | ) |
428 | ) |
429 | [^&] # Not an ampersand (which means a dup) |
430 | }x; |
431 | |
02b13d1d |
432 | if (not $mode) { |
433 | # Maybe it's a 2-arg open without any mode at all? |
434 | # Detect the most simple case for this, where our |
435 | # file consists only of word characters. |
436 | |
437 | if ( $file =~ m{^\s*\w+\s*$} ) { |
438 | $mode = '<' |
439 | } |
440 | else { |
441 | # Otherwise, we've got no idea what's going on. |
442 | # Use the default. |
443 | return $this->format_default; |
444 | } |
445 | } |
0b09a93a |
446 | |
447 | # Localising $! means perl make make it a pretty error for us. |
448 | local $! = $this->errno; |
449 | |
450 | return $this->_format_open_with_mode($mode, $file, $!); |
451 | } |
452 | |
453 | # Here we must be using three arg open. |
454 | |
455 | my $file = $open_args[2]; |
456 | |
457 | local $! = $this->errno; |
458 | |
459 | my $mode = $open_args[1]; |
460 | |
461 | local $@; |
462 | |
463 | my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); }; |
464 | |
465 | return $msg if $msg; |
466 | |
467 | # Default message (for pipes and odd things) |
468 | |
469 | return "Can't open '$file' with mode '$open_args[1]': '$!'"; |
470 | } |
471 | |
472 | =head3 register |
473 | |
474 | autodie::exception->register( 'CORE::open' => \&mysub ); |
475 | |
476 | The C<register> method allows for the registration of a message |
477 | handler for a given subroutine. The full subroutine name including |
478 | the package should be used. |
479 | |
480 | Registered message handlers will receive the C<autodie::exception> |
481 | object as the first parameter. |
482 | |
483 | =cut |
484 | |
485 | sub register { |
486 | my ($class, $symbol, $handler) = @_; |
487 | |
488 | croak "Incorrect call to autodie::register" if @_ != 3; |
489 | |
490 | $formatter_of{$symbol} = $handler; |
491 | |
492 | } |
493 | |
494 | =head3 add_file_and_line |
495 | |
496 | say "Problem occurred",$@->add_file_and_line; |
497 | |
498 | Returns the string C< at %s line %d>, where C<%s> is replaced with |
499 | the filename, and C<%d> is replaced with the line number. |
500 | |
501 | Primarily intended for use by format handlers. |
502 | |
503 | =cut |
504 | |
505 | # Simply produces the file and line number; intended to be added |
506 | # to the end of error messages. |
507 | |
508 | sub add_file_and_line { |
509 | my ($this) = @_; |
510 | |
511 | return sprintf(" at %s line %d\n", $this->file, $this->line); |
512 | } |
513 | |
514 | =head3 stringify |
515 | |
516 | say "The error was: ",$@->stringify; |
517 | |
518 | Formats the error as a human readable string. Usually there's no |
519 | reason to call this directly, as it is used automatically if an |
520 | C<autodie::exception> object is ever used as a string. |
521 | |
522 | Child classes can override this method to change how they're |
523 | stringified. |
524 | |
525 | =cut |
526 | |
527 | sub stringify { |
528 | my ($this) = @_; |
529 | |
530 | my $call = $this->function; |
531 | |
532 | if ($DEBUG) { |
533 | my $dying_pkg = $this->package; |
534 | my $sub = $this->function; |
535 | my $caller = $this->caller; |
536 | warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n"; |
537 | } |
538 | |
539 | # TODO - This isn't using inheritance. Should it? |
540 | if ( my $sub = $formatter_of{$call} ) { |
541 | return $sub->($this) . $this->add_file_and_line; |
542 | } |
543 | |
02b13d1d |
544 | return $this->format_default . $this->add_file_and_line; |
0b09a93a |
545 | |
546 | } |
547 | |
548 | =head3 format_default |
549 | |
550 | my $error_string = $E->format_default; |
551 | |
552 | This produces the default error string for the given exception, |
553 | I<without using any registered message handlers>. It is primarily |
554 | intended to be called from a message handler when they have |
555 | been passed an exception they don't want to format. |
556 | |
557 | Child classes can override this method to change how default |
558 | messages are formatted. |
559 | |
560 | =cut |
561 | |
562 | # TODO: This produces ugly errors. Is there any way we can |
563 | # dig around to find the actual variable names? I know perl 5.10 |
564 | # does some dark and terrible magicks to find them for undef warnings. |
565 | |
566 | sub format_default { |
567 | my ($this) = @_; |
568 | |
569 | my $call = $this->function; |
570 | |
571 | local $! = $this->errno; |
572 | |
573 | # TODO: This is probably a good idea for CORE, is it |
574 | # a good idea for other subs? |
575 | |
576 | # Trim package name off dying sub for error messages. |
577 | $call =~ s/.*:://; |
578 | |
579 | # Walk through all our arguments, and... |
580 | # |
581 | # * Replace undef with the word 'undef' |
582 | # * Replace globs with the string '$fh' |
583 | # * Quote all other args. |
584 | |
585 | my @args = @{ $this->args() }; |
586 | |
587 | foreach my $arg (@args) { |
588 | if (not defined($arg)) { $arg = 'undef' } |
589 | elsif (ref($arg) eq "GLOB") { $arg = '$fh' } |
590 | else { $arg = qq{'$arg'} } |
591 | } |
592 | |
593 | # Format our beautiful error. |
594 | |
02b13d1d |
595 | return "Can't $call(". join(q{, }, @args) . "): $!" ; |
0b09a93a |
596 | |
597 | # TODO - Handle user-defined errors from hash. |
598 | |
599 | # TODO - Handle default error messages. |
600 | |
601 | } |
602 | |
603 | =head3 new |
604 | |
605 | my $error = autodie::exception->new( |
606 | args => \@_, |
607 | function => "CORE::open", |
608 | errno => $!, |
eb8d423f |
609 | context => 'scalar', |
610 | return => undef, |
0b09a93a |
611 | ); |
612 | |
613 | |
614 | Creates a new C<autodie::exception> object. Normally called |
615 | directly from an autodying function. The C<function> argument |
616 | is required, its the function we were trying to call that |
617 | generated the exception. The C<args> parameter is optional. |
618 | |
619 | The C<errno> value is optional. In versions of C<autodie::exception> |
620 | 1.99 and earlier the code would try to automatically use the |
621 | current value of C<$!>, but this was unreliable and is no longer |
622 | supported. |
623 | |
624 | Atrributes such as package, file, and caller are determined |
625 | automatically, and cannot be specified. |
626 | |
627 | =cut |
628 | |
629 | sub new { |
630 | my ($class, @args) = @_; |
631 | |
632 | my $this = {}; |
633 | |
634 | bless($this,$class); |
635 | |
636 | # I'd love to use EVERY here, but it causes our code to die |
637 | # because it wants to stringify our objects before they're |
638 | # initialised, causing everything to explode. |
639 | |
640 | $this->_init(@args); |
641 | |
642 | return $this; |
643 | } |
644 | |
645 | sub _init { |
646 | |
647 | my ($this, %args) = @_; |
648 | |
649 | # Capturing errno here is not necessarily reliable. |
650 | my $original_errno = $!; |
651 | |
652 | our $init_called = 1; |
653 | |
654 | my $class = ref $this; |
655 | |
656 | # We're going to walk up our call stack, looking for the |
657 | # first thing that doesn't look like our exception |
658 | # code, autodie/Fatal, or some whacky eval. |
659 | |
660 | my ($package, $file, $line, $sub); |
661 | |
662 | my $depth = 0; |
663 | |
664 | while (1) { |
665 | $depth++; |
666 | |
667 | ($package, $file, $line, $sub) = CORE::caller($depth); |
668 | |
669 | # Skip up the call stack until we find something outside |
670 | # of the Fatal/autodie/eval space. |
671 | |
672 | next if $package->isa('Fatal'); |
673 | next if $package->isa($class); |
674 | next if $package->isa(__PACKAGE__); |
675 | next if $file =~ /^\(eval\s\d+\)$/; |
676 | |
677 | last; |
678 | |
679 | } |
680 | |
db4e6d09 |
681 | # We now have everything correct, *except* for our subroutine |
682 | # name. If it's __ANON__ or (eval), then we need to keep on |
683 | # digging deeper into our stack to find the real name. However we |
684 | # don't update our other information, since that will be correct |
685 | # for our current exception. |
686 | |
687 | my $first_guess_subroutine = $sub; |
688 | |
689 | while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { |
690 | $depth++; |
691 | |
692 | $sub = (CORE::caller($depth))[3]; |
693 | } |
694 | |
695 | # If we end up falling out the bottom of our stack, then our |
696 | # __ANON__ guess is the best we can get. This includes situations |
9b657a62 |
697 | # where we were called from the top level of a program. |
db4e6d09 |
698 | |
699 | if (not defined $sub) { |
700 | $sub = $first_guess_subroutine; |
701 | } |
702 | |
0b09a93a |
703 | $this->{$PACKAGE}{package} = $package; |
704 | $this->{$PACKAGE}{file} = $file; |
705 | $this->{$PACKAGE}{line} = $line; |
706 | $this->{$PACKAGE}{caller} = $sub; |
707 | $this->{$PACKAGE}{package} = $package; |
708 | |
709 | $this->{$PACKAGE}{errno} = $args{errno} || 0; |
710 | |
eb8d423f |
711 | $this->{$PACKAGE}{context} = $args{context}; |
712 | $this->{$PACKAGE}{return} = $args{return}; |
7840a289 |
713 | $this->{$PACKAGE}{eval_error} = $args{eval_error}; |
eb8d423f |
714 | |
0b09a93a |
715 | $this->{$PACKAGE}{args} = $args{args} || []; |
716 | $this->{$PACKAGE}{function}= $args{function} or |
717 | croak("$class->new() called without function arg"); |
718 | |
719 | return $this; |
720 | |
721 | } |
722 | |
723 | 1; |
724 | |
725 | __END__ |
726 | |
727 | =head1 SEE ALSO |
728 | |
729 | L<autodie>, L<autodie::exception::system> |
730 | |
731 | =head1 LICENSE |
732 | |
733 | Copyright (C)2008 Paul Fenwick |
734 | |
735 | This is free software. You may modify and/or redistribute this |
736 | code under the same terms as Perl 5.10 itself, or, at your option, |
737 | any later version of Perl 5. |
738 | |
739 | =head1 AUTHOR |
740 | |
741 | Paul Fenwick E<lt>pjf@perltraining.com.auE<gt> |