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.05';
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 if ( $e->matches('open') ) { ... }
177 if ( $e ~~ 'open' ) { ... }
179 C<matches> is used to determine whether a
180 given exception matches a particular role. On Perl 5.10,
181 using smart-match (C<~~>) with an C<autodie::exception> object
182 will use C<matches> underneath.
184 An exception is considered to match a string if:
190 For a string not starting with a colon, the string exactly matches the
191 package and subroutine that threw the exception. For example,
192 C<MyModule::log>. If the string does not contain a package name,
193 C<CORE::> is assumed.
197 For a string that does start with a colon, if the subroutine
198 throwing the exception I<does> that behaviour. For example, the
199 C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
201 See L<autodie/CATEGORIES> for futher information.
211 my ($this, $that) = @_;
213 # TODO - Handle references
214 croak "UNIMPLEMENTED" if ref $that;
216 my $sub = $this->function;
219 my $sub2 = $this->function;
220 warn "Smart-matching $that against $sub / $sub2\n";
223 # Direct subname match.
224 return 1 if $that eq $sub;
225 return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
226 return 0 if $that !~ /^:/;
228 # Cached match / check tags.
231 if (exists $cache{$sub}{$that}) {
232 return $cache{$sub}{$that};
235 # This rather awful looking line checks to see if our sub is in the
236 # list of expanded tags, caches it, and returns the result.
238 return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
242 # This exists primarily so that child classes can override or
243 # augment it if they wish.
246 my ($this, @args) = @_;
248 return Fatal->_expand_tag(@args);
251 =head2 Advanced methods
253 The following methods, while usable from anywhere, are primarily
254 intended for developers wishing to subclass C<autodie::exception>,
255 write code that registers custom error messages, or otherwise
256 work closely with the C<autodie::exception> model.
260 # The table below records customer formatters.
261 # TODO - Should this be a package var instead?
262 # TODO - Should these be in a completely different file, or
263 # perhaps loaded on demand? Most formatters will never
264 # get used in most programs.
267 'CORE::close' => \&_format_close,
268 'CORE::open' => \&_format_open,
269 'CORE::dbmopen' => \&_format_dbmopen,
270 'CORE::flock' => \&_format_flock,
273 # TODO: Our tests only check LOCK_EX | LOCK_NB is properly
274 # formatted. Try other combinations and ensure they work
282 my $filehandle = $this->args->[0];
283 my $raw_mode = $this->args->[1];
288 if ($raw_mode & Fcntl::LOCK_EX() ) {
289 $lock_unlock = "lock";
290 $mode_type = "for exclusive access";
292 elsif ($raw_mode & Fcntl::LOCK_SH() ) {
293 $lock_unlock = "lock";
294 $mode_type = "for shared access";
296 elsif ($raw_mode & Fcntl::LOCK_UN() ) {
297 $lock_unlock = "unlock";
301 # I've got no idea what they're trying to do.
302 $lock_unlock = "lock";
303 $mode_type = "with mode $raw_mode";
306 my $cooked_filehandle;
308 if ($filehandle and not ref $filehandle) {
310 # A package filehandle with a name!
312 $cooked_filehandle = " $filehandle";
315 # Otherwise we have a scalar filehandle.
317 $cooked_filehandle = '';
321 local $! = $this->errno;
323 return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
327 # Default formatter for CORE::dbmopen
328 sub _format_dbmopen {
330 my @args = @{$this->args};
332 # TODO: Presently, $args flattens out the (usually empty) hash
333 # which is passed as the first argument to dbmopen. This is
334 # a bug in our args handling code (taking a reference to it would
335 # be better), but for the moment we'll just examine the end of
336 # our arguments list for message formatting.
338 my $mode = $args[-1];
339 my $file = $args[-2];
341 # If we have a mask, then display it in octal, not decimal.
342 # We don't do this if it already looks octalish, or doesn't
343 # look like a number.
345 if ($mode =~ /^[^\D0]\d+$/) {
346 $mode = sprintf("0%lo", $mode);
349 local $! = $this->errno;
351 return "Can't dbmopen(%hash, '$file', $mode): '$!'";
354 # Default formatter for CORE::close
358 my $close_arg = $this->args->[0];
360 local $! = $this->errno;
362 # If we've got an old-style filehandle, mention it.
363 if ($close_arg and not ref $close_arg) {
364 return "Can't close filehandle '$close_arg': '$!'";
367 # TODO - This will probably produce an ugly error. Test and fix.
368 return "Can't close($close_arg) filehandle: '$!'";
372 # Default formatter for CORE::open
374 use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
376 sub _format_open_with_mode {
377 my ($this, $mode, $file, $error) = @_;
381 if ($mode eq '<') { $wordy_mode = 'reading'; }
382 elsif ($mode eq '>') { $wordy_mode = 'writing'; }
383 elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
385 return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
387 Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
394 my @open_args = @{$this->args};
396 # Use the default formatter for single-arg and many-arg open
397 if (@open_args <= 1 or @open_args >= 4) {
398 return $this->format_default;
401 # For two arg open, we have to extract the mode
402 if (@open_args == 2) {
403 my ($fh, $file) = @open_args;
405 if (ref($fh) eq "GLOB") {
409 my ($mode) = $file =~ m{
410 ^\s* # Spaces before mode
412 (?> # Non-backtracking subexp.
414 |>>? # Writing/appending
417 [^&] # Not an ampersand (which means a dup)
421 # Maybe it's a 2-arg open without any mode at all?
422 # Detect the most simple case for this, where our
423 # file consists only of word characters.
425 if ( $file =~ m{^\s*\w+\s*$} ) {
429 # Otherwise, we've got no idea what's going on.
431 return $this->format_default;
435 # Localising $! means perl make make it a pretty error for us.
436 local $! = $this->errno;
438 return $this->_format_open_with_mode($mode, $file, $!);
441 # Here we must be using three arg open.
443 my $file = $open_args[2];
445 local $! = $this->errno;
447 my $mode = $open_args[1];
451 my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
455 # Default message (for pipes and odd things)
457 return "Can't open '$file' with mode '$open_args[1]': '$!'";
462 autodie::exception->register( 'CORE::open' => \&mysub );
464 The C<register> method allows for the registration of a message
465 handler for a given subroutine. The full subroutine name including
466 the package should be used.
468 Registered message handlers will receive the C<autodie::exception>
469 object as the first parameter.
474 my ($class, $symbol, $handler) = @_;
476 croak "Incorrect call to autodie::register" if @_ != 3;
478 $formatter_of{$symbol} = $handler;
482 =head3 add_file_and_line
484 say "Problem occurred",$@->add_file_and_line;
486 Returns the string C< at %s line %d>, where C<%s> is replaced with
487 the filename, and C<%d> is replaced with the line number.
489 Primarily intended for use by format handlers.
493 # Simply produces the file and line number; intended to be added
494 # to the end of error messages.
496 sub add_file_and_line {
499 return sprintf(" at %s line %d\n", $this->file, $this->line);
504 say "The error was: ",$@->stringify;
506 Formats the error as a human readable string. Usually there's no
507 reason to call this directly, as it is used automatically if an
508 C<autodie::exception> object is ever used as a string.
510 Child classes can override this method to change how they're
518 my $call = $this->function;
521 my $dying_pkg = $this->package;
522 my $sub = $this->function;
523 my $caller = $this->caller;
524 warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
527 # TODO - This isn't using inheritance. Should it?
528 if ( my $sub = $formatter_of{$call} ) {
529 return $sub->($this) . $this->add_file_and_line;
532 return $this->format_default . $this->add_file_and_line;
536 =head3 format_default
538 my $error_string = $E->format_default;
540 This produces the default error string for the given exception,
541 I<without using any registered message handlers>. It is primarily
542 intended to be called from a message handler when they have
543 been passed an exception they don't want to format.
545 Child classes can override this method to change how default
546 messages are formatted.
550 # TODO: This produces ugly errors. Is there any way we can
551 # dig around to find the actual variable names? I know perl 5.10
552 # does some dark and terrible magicks to find them for undef warnings.
557 my $call = $this->function;
559 local $! = $this->errno;
561 # TODO: This is probably a good idea for CORE, is it
562 # a good idea for other subs?
564 # Trim package name off dying sub for error messages.
567 # Walk through all our arguments, and...
569 # * Replace undef with the word 'undef'
570 # * Replace globs with the string '$fh'
571 # * Quote all other args.
573 my @args = @{ $this->args() };
575 foreach my $arg (@args) {
576 if (not defined($arg)) { $arg = 'undef' }
577 elsif (ref($arg) eq "GLOB") { $arg = '$fh' }
578 else { $arg = qq{'$arg'} }
581 # Format our beautiful error.
583 return "Can't $call(". join(q{, }, @args) . "): $!" ;
585 # TODO - Handle user-defined errors from hash.
587 # TODO - Handle default error messages.
593 my $error = autodie::exception->new(
595 function => "CORE::open",
602 Creates a new C<autodie::exception> object. Normally called
603 directly from an autodying function. The C<function> argument
604 is required, its the function we were trying to call that
605 generated the exception. The C<args> parameter is optional.
607 The C<errno> value is optional. In versions of C<autodie::exception>
608 1.99 and earlier the code would try to automatically use the
609 current value of C<$!>, but this was unreliable and is no longer
612 Atrributes such as package, file, and caller are determined
613 automatically, and cannot be specified.
618 my ($class, @args) = @_;
624 # I'd love to use EVERY here, but it causes our code to die
625 # because it wants to stringify our objects before they're
626 # initialised, causing everything to explode.
635 my ($this, %args) = @_;
637 # Capturing errno here is not necessarily reliable.
638 my $original_errno = $!;
640 our $init_called = 1;
642 my $class = ref $this;
644 # We're going to walk up our call stack, looking for the
645 # first thing that doesn't look like our exception
646 # code, autodie/Fatal, or some whacky eval.
648 my ($package, $file, $line, $sub);
655 ($package, $file, $line, $sub) = CORE::caller($depth);
657 # Skip up the call stack until we find something outside
658 # of the Fatal/autodie/eval space.
660 next if $package->isa('Fatal');
661 next if $package->isa($class);
662 next if $package->isa(__PACKAGE__);
663 next if $file =~ /^\(eval\s\d+\)$/;
669 # We now have everything correct, *except* for our subroutine
670 # name. If it's __ANON__ or (eval), then we need to keep on
671 # digging deeper into our stack to find the real name. However we
672 # don't update our other information, since that will be correct
673 # for our current exception.
675 my $first_guess_subroutine = $sub;
677 while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) {
680 $sub = (CORE::caller($depth))[3];
683 # If we end up falling out the bottom of our stack, then our
684 # __ANON__ guess is the best we can get. This includes situations
685 # where we were called from the top level of a program.
687 if (not defined $sub) {
688 $sub = $first_guess_subroutine;
691 $this->{$PACKAGE}{package} = $package;
692 $this->{$PACKAGE}{file} = $file;
693 $this->{$PACKAGE}{line} = $line;
694 $this->{$PACKAGE}{caller} = $sub;
695 $this->{$PACKAGE}{package} = $package;
697 $this->{$PACKAGE}{errno} = $args{errno} || 0;
699 $this->{$PACKAGE}{context} = $args{context};
700 $this->{$PACKAGE}{return} = $args{return};
702 $this->{$PACKAGE}{args} = $args{args} || [];
703 $this->{$PACKAGE}{function}= $args{function} or
704 croak("$class->new() called without function arg");
716 L<autodie>, L<autodie::exception::system>
720 Copyright (C)2008 Paul Fenwick
722 This is free software. You may modify and/or redistribute this
723 code under the same terms as Perl 5.10 itself, or, at your option,
724 any later version of Perl 5.
728 Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>