1 package autodie::exception;
13 # Overload smart-match only if we're using 5.10
15 use if ($] >= 5.010), overload => '~~' => "matches";
17 our $VERSION = '2.06_01';
19 my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys.
23 autodie::exception - Exceptions from autodying functions.
30 open(my $fh, '<', 'some_file.txt');
36 say "Ooops! ",$E->caller," had problems: $@";
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.
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>.
53 These methods are intended to be used in the everyday dealing
56 The following assume that the error has been copied into
63 This is not required, but is recommended in case any code
64 is called which may reset or alter C<$@>.
70 my $array_ref = $E->args;
72 Provides a reference to the arguments passed to the subroutine
77 sub args { return $_[0]->{$PACKAGE}{args}; }
81 my $sub = $E->function;
83 The subroutine (including package) that threw the exception.
87 sub function { return $_[0]->{$PACKAGE}{function}; }
93 The file in which the error occurred (eg, C<myscript.pl> or
98 sub file { return $_[0]->{$PACKAGE}{file}; }
102 my $package = $E->package;
104 The package from which the exceptional subroutine was called.
108 sub package { return $_[0]->{$PACKAGE}{package}; }
112 my $caller = $E->caller;
114 The subroutine that I<called> the exceptional code.
118 sub caller { return $_[0]->{$PACKAGE}{caller}; }
124 The line in C<< $E->file >> where the exceptional code was called.
128 sub line { return $_[0]->{$PACKAGE}{line}; }
132 my $context = $E->context;
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.
140 sub context { return $_[0]->{$PACKAGE}{context} }
144 my $return_value = $E->return;
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.
153 sub return { return $_[0]->{$PACKAGE}{return} }
157 my $errno = $E->errno;
159 The value of C<$!> at the time when the exception occurred.
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
168 # TODO: Make errno part of a role. It doesn't make sense for
171 sub errno { return $_[0]->{$PACKAGE}{errno}; }
175 my $old_eval_error = $E->eval_error;
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.
183 sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; }
187 if ( $e->matches('open') ) { ... }
189 if ( $e ~~ 'open' ) { ... }
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.
196 An exception is considered to match a string if:
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.
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>.
213 See L<autodie/CATEGORIES> for futher information.
223 my ($this, $that) = @_;
225 # TODO - Handle references
226 croak "UNIMPLEMENTED" if ref $that;
228 my $sub = $this->function;
231 my $sub2 = $this->function;
232 warn "Smart-matching $that against $sub / $sub2\n";
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 !~ /^:/;
240 # Cached match / check tags.
243 if (exists $cache{$sub}{$that}) {
244 return $cache{$sub}{$that};
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.
250 return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
254 # This exists primarily so that child classes can override or
255 # augment it if they wish.
258 my ($this, @args) = @_;
260 return Fatal->_expand_tag(@args);
263 =head2 Advanced methods
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.
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.
279 'CORE::close' => \&_format_close,
280 'CORE::open' => \&_format_open,
281 'CORE::dbmopen' => \&_format_dbmopen,
282 'CORE::flock' => \&_format_flock,
285 # TODO: Our tests only check LOCK_EX | LOCK_NB is properly
286 # formatted. Try other combinations and ensure they work
294 my $filehandle = $this->args->[0];
295 my $raw_mode = $this->args->[1];
300 if ($raw_mode & Fcntl::LOCK_EX() ) {
301 $lock_unlock = "lock";
302 $mode_type = "for exclusive access";
304 elsif ($raw_mode & Fcntl::LOCK_SH() ) {
305 $lock_unlock = "lock";
306 $mode_type = "for shared access";
308 elsif ($raw_mode & Fcntl::LOCK_UN() ) {
309 $lock_unlock = "unlock";
313 # I've got no idea what they're trying to do.
314 $lock_unlock = "lock";
315 $mode_type = "with mode $raw_mode";
318 my $cooked_filehandle;
320 if ($filehandle and not ref $filehandle) {
322 # A package filehandle with a name!
324 $cooked_filehandle = " $filehandle";
327 # Otherwise we have a scalar filehandle.
329 $cooked_filehandle = '';
333 local $! = $this->errno;
335 return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
339 # Default formatter for CORE::dbmopen
340 sub _format_dbmopen {
342 my @args = @{$this->args};
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.
350 my $mode = $args[-1];
351 my $file = $args[-2];
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.
357 if ($mode =~ /^[^\D0]\d+$/) {
358 $mode = sprintf("0%lo", $mode);
361 local $! = $this->errno;
363 return "Can't dbmopen(%hash, '$file', $mode): '$!'";
366 # Default formatter for CORE::close
370 my $close_arg = $this->args->[0];
372 local $! = $this->errno;
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': '$!'";
379 # TODO - This will probably produce an ugly error. Test and fix.
380 return "Can't close($close_arg) filehandle: '$!'";
384 # Default formatter for CORE::open
386 use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
388 sub _format_open_with_mode {
389 my ($this, $mode, $file, $error) = @_;
393 if ($mode eq '<') { $wordy_mode = 'reading'; }
394 elsif ($mode eq '>') { $wordy_mode = 'writing'; }
395 elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
397 return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
399 Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
406 my @open_args = @{$this->args};
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;
413 # For two arg open, we have to extract the mode
414 if (@open_args == 2) {
415 my ($fh, $file) = @open_args;
417 if (ref($fh) eq "GLOB") {
421 my ($mode) = $file =~ m{
422 ^\s* # Spaces before mode
424 (?> # Non-backtracking subexp.
426 |>>? # Writing/appending
429 [^&] # Not an ampersand (which means a dup)
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.
437 if ( $file =~ m{^\s*\w+\s*$} ) {
441 # Otherwise, we've got no idea what's going on.
443 return $this->format_default;
447 # Localising $! means perl make make it a pretty error for us.
448 local $! = $this->errno;
450 return $this->_format_open_with_mode($mode, $file, $!);
453 # Here we must be using three arg open.
455 my $file = $open_args[2];
457 local $! = $this->errno;
459 my $mode = $open_args[1];
463 my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
467 # Default message (for pipes and odd things)
469 return "Can't open '$file' with mode '$open_args[1]': '$!'";
474 autodie::exception->register( 'CORE::open' => \&mysub );
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.
480 Registered message handlers will receive the C<autodie::exception>
481 object as the first parameter.
486 my ($class, $symbol, $handler) = @_;
488 croak "Incorrect call to autodie::register" if @_ != 3;
490 $formatter_of{$symbol} = $handler;
494 =head3 add_file_and_line
496 say "Problem occurred",$@->add_file_and_line;
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.
501 Primarily intended for use by format handlers.
505 # Simply produces the file and line number; intended to be added
506 # to the end of error messages.
508 sub add_file_and_line {
511 return sprintf(" at %s line %d\n", $this->file, $this->line);
516 say "The error was: ",$@->stringify;
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.
522 Child classes can override this method to change how they're
530 my $call = $this->function;
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";
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;
544 return $this->format_default . $this->add_file_and_line;
548 =head3 format_default
550 my $error_string = $E->format_default;
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.
557 Child classes can override this method to change how default
558 messages are formatted.
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.
569 my $call = $this->function;
571 local $! = $this->errno;
573 # TODO: This is probably a good idea for CORE, is it
574 # a good idea for other subs?
576 # Trim package name off dying sub for error messages.
579 # Walk through all our arguments, and...
581 # * Replace undef with the word 'undef'
582 # * Replace globs with the string '$fh'
583 # * Quote all other args.
585 my @args = @{ $this->args() };
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'} }
593 # Format our beautiful error.
595 return "Can't $call(". join(q{, }, @args) . "): $!" ;
597 # TODO - Handle user-defined errors from hash.
599 # TODO - Handle default error messages.
605 my $error = autodie::exception->new(
607 function => "CORE::open",
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.
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
624 Atrributes such as package, file, and caller are determined
625 automatically, and cannot be specified.
630 my ($class, @args) = @_;
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.
647 my ($this, %args) = @_;
649 # Capturing errno here is not necessarily reliable.
650 my $original_errno = $!;
652 our $init_called = 1;
654 my $class = ref $this;
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.
660 my ($package, $file, $line, $sub);
667 ($package, $file, $line, $sub) = CORE::caller($depth);
669 # Skip up the call stack until we find something outside
670 # of the Fatal/autodie/eval space.
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+\)$/;
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.
687 my $first_guess_subroutine = $sub;
689 while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
692 $sub = (CORE::caller($depth))[3];
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
697 # where we were called from the top level of a program.
699 if (not defined $sub) {
700 $sub = $first_guess_subroutine;
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;
709 $this->{$PACKAGE}{errno} = $args{errno} || 0;
711 $this->{$PACKAGE}{context} = $args{context};
712 $this->{$PACKAGE}{return} = $args{return};
713 $this->{$PACKAGE}{eval_error} = $args{eval_error};
715 $this->{$PACKAGE}{args} = $args{args} || [];
716 $this->{$PACKAGE}{function}= $args{function} or
717 croak("$class->new() called without function arg");
729 L<autodie>, L<autodie::exception::system>
733 Copyright (C)2008 Paul Fenwick
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.
741 Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>