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 = '1.998';
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 $errno = $E->errno;
134 The value of C<$!> at the time when the exception occurred.
136 B<NOTE>: This method will leave the main C<autodie::exception> class
137 and become part of a role in the future. You should only call
138 C<errno> for exceptions where C<$!> would reasonably have been
143 # TODO: Make errno part of a role. It doesn't make sense for
146 sub errno { return $_[0]->{$PACKAGE}{errno}; }
150 if ( $e->matches('open') ) { ... }
152 if ( $e ~~ 'open' ) { ... }
154 C<matches> is used to determine whether a
155 given exception matches a particular role. On Perl 5.10,
156 using smart-match (C<~~>) with an C<autodie::exception> object
157 will use C<matches> underneath.
159 An exception is considered to match a string if:
165 For a string not starting with a colon, the string exactly matches the
166 package and subroutine that threw the exception. For example,
167 C<MyModule::log>. If the string does not contain a package name,
168 C<CORE::> is assumed.
172 For a string that does start with a colon, if the subroutine
173 throwing the exception I<does> that behaviour. For example, the
174 C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
176 See L<autodie/CATEGORIES> for futher information.
186 my ($this, $that) = @_;
188 # XXX - Handle references
189 croak "UNIMPLEMENTED" if ref $that;
191 my $sub = $this->function;
194 my $sub2 = $this->function;
195 warn "Smart-matching $that against $sub / $sub2\n";
198 # Direct subname match.
199 return 1 if $that eq $sub;
200 return 1 if $that !~ /:/ and "CORE::$that" eq $sub;
201 return 0 if $that !~ /^:/;
203 # Cached match / check tags.
206 if (exists $cache{$sub}{$that}) {
207 return $cache{$sub}{$that};
210 # This rather awful looking line checks to see if our sub is in the
211 # list of expanded tags, caches it, and returns the result.
213 return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) };
217 # This exists primarily so that child classes can override or
218 # augment it if they wish.
221 my ($this, @args) = @_;
223 return Fatal->_expand_tag(@args);
226 =head2 Advanced methods
228 The following methods, while usable from anywhere, are primarily
229 intended for developers wishing to subclass C<autodie::exception>,
230 write code that registers custom error messages, or otherwise
231 work closely with the C<autodie::exception> model.
235 # The table below records customer formatters.
236 # TODO - Should this be a package var instead?
237 # TODO - Should these be in a completely different file, or
238 # perhaps loaded on demand? Most formatters will never
239 # get used in most programs.
242 'CORE::close' => \&_format_close,
243 'CORE::open' => \&_format_open,
244 'CORE::dbmopen' => \&_format_dbmopen,
245 'CORE::flock' => \&_format_flock,
248 # TODO: Our tests only check LOCK_EX | LOCK_NB is properly
249 # formatted. Try other combinations and ensure they work
257 my $filehandle = $this->args->[0];
258 my $raw_mode = $this->args->[1];
263 if ($raw_mode & Fcntl::LOCK_EX() ) {
264 $lock_unlock = "lock";
265 $mode_type = "for exclusive access";
267 elsif ($raw_mode & Fcntl::LOCK_SH() ) {
268 $lock_unlock = "lock";
269 $mode_type = "for shared access";
271 elsif ($raw_mode & Fcntl::LOCK_UN() ) {
272 $lock_unlock = "unlock";
276 # I've got no idea what they're trying to do.
277 $lock_unlock = "lock";
278 $mode_type = "with mode $raw_mode";
281 my $cooked_filehandle;
283 if ($filehandle and not ref $filehandle) {
285 # A package filehandle with a name!
287 $cooked_filehandle = " $filehandle";
290 # Otherwise we have a scalar filehandle.
292 $cooked_filehandle = '';
296 local $! = $this->errno;
298 return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!";
302 # Default formatter for CORE::dbmopen
303 sub _format_dbmopen {
305 my @args = @{$this->args};
307 # TODO: Presently, $args flattens out the (usually empty) hash
308 # which is passed as the first argument to dbmopen. This is
309 # a bug in our args handling code (taking a reference to it would
310 # be better), but for the moment we'll just examine the end of
311 # our arguments list for message formatting.
313 my $mode = $args[-1];
314 my $file = $args[-2];
316 # If we have a mask, then display it in octal, not decimal.
317 # We don't do this if it already looks octalish, or doesn't
318 # look like a number.
320 if ($mode =~ /^[^\D0]\d+$/) {
321 $mode = sprintf("0%lo", $mode);
324 local $! = $this->errno;
326 return "Can't dbmopen(%hash, '$file', $mode): '$!'";
329 # Default formatter for CORE::close
333 my $close_arg = $this->args->[0];
335 local $! = $this->errno;
337 # If we've got an old-style filehandle, mention it.
338 if ($close_arg and not ref $close_arg) {
339 return "Can't close filehandle '$close_arg': '$!'";
342 # TODO - This will probably produce an ugly error. Test and fix.
343 return "Can't close($close_arg) filehandle: '$!'";
347 # Default formatter for CORE::open
349 use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'";
351 sub _format_open_with_mode {
352 my ($this, $mode, $file, $error) = @_;
356 if ($mode eq '<') { $wordy_mode = 'reading'; }
357 elsif ($mode eq '>') { $wordy_mode = 'writing'; }
358 elsif ($mode eq '>>') { $wordy_mode = 'appending'; }
360 return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode;
362 Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'.");
369 my @open_args = @{$this->args};
371 # Use the default formatter for single-arg and many-arg open
372 if (@open_args <= 1 or @open_args >= 4) {
373 return $this->format_default;
376 # For two arg open, we have to extract the mode
377 if (@open_args == 2) {
378 my ($fh, $file) = @open_args;
380 if (ref($fh) eq "GLOB") {
384 my ($mode) = $file =~ m{
385 ^\s* # Spaces before mode
387 (?> # Non-backtracking subexp.
389 |>>? # Writing/appending
392 [^&] # Not an ampersand (which means a dup)
395 # Have a funny mode? Use the default format.
396 return $this->format_default if not defined $mode;
398 # Localising $! means perl make make it a pretty error for us.
399 local $! = $this->errno;
401 return $this->_format_open_with_mode($mode, $file, $!);
404 # Here we must be using three arg open.
406 my $file = $open_args[2];
408 local $! = $this->errno;
410 my $mode = $open_args[1];
414 my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); };
418 # Default message (for pipes and odd things)
420 return "Can't open '$file' with mode '$open_args[1]': '$!'";
425 autodie::exception->register( 'CORE::open' => \&mysub );
427 The C<register> method allows for the registration of a message
428 handler for a given subroutine. The full subroutine name including
429 the package should be used.
431 Registered message handlers will receive the C<autodie::exception>
432 object as the first parameter.
437 my ($class, $symbol, $handler) = @_;
439 croak "Incorrect call to autodie::register" if @_ != 3;
441 $formatter_of{$symbol} = $handler;
445 =head3 add_file_and_line
447 say "Problem occurred",$@->add_file_and_line;
449 Returns the string C< at %s line %d>, where C<%s> is replaced with
450 the filename, and C<%d> is replaced with the line number.
452 Primarily intended for use by format handlers.
456 # Simply produces the file and line number; intended to be added
457 # to the end of error messages.
459 sub add_file_and_line {
462 return sprintf(" at %s line %d\n", $this->file, $this->line);
467 say "The error was: ",$@->stringify;
469 Formats the error as a human readable string. Usually there's no
470 reason to call this directly, as it is used automatically if an
471 C<autodie::exception> object is ever used as a string.
473 Child classes can override this method to change how they're
481 my $call = $this->function;
484 my $dying_pkg = $this->package;
485 my $sub = $this->function;
486 my $caller = $this->caller;
487 warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n";
490 # TODO - This isn't using inheritance. Should it?
491 if ( my $sub = $formatter_of{$call} ) {
492 return $sub->($this) . $this->add_file_and_line;
495 return $this->format_default;
499 =head3 format_default
501 my $error_string = $E->format_default;
503 This produces the default error string for the given exception,
504 I<without using any registered message handlers>. It is primarily
505 intended to be called from a message handler when they have
506 been passed an exception they don't want to format.
508 Child classes can override this method to change how default
509 messages are formatted.
513 # TODO: This produces ugly errors. Is there any way we can
514 # dig around to find the actual variable names? I know perl 5.10
515 # does some dark and terrible magicks to find them for undef warnings.
520 my $call = $this->function;
522 local $! = $this->errno;
524 # TODO: This is probably a good idea for CORE, is it
525 # a good idea for other subs?
527 # Trim package name off dying sub for error messages.
530 # Walk through all our arguments, and...
532 # * Replace undef with the word 'undef'
533 # * Replace globs with the string '$fh'
534 # * Quote all other args.
536 my @args = @{ $this->args() };
538 foreach my $arg (@args) {
539 if (not defined($arg)) { $arg = 'undef' }
540 elsif (ref($arg) eq "GLOB") { $arg = '$fh' }
541 else { $arg = qq{'$arg'} }
544 # Format our beautiful error.
546 return "Can't $call(". join(q{, }, @args) . "): $!" .
547 $this->add_file_and_line;
549 # TODO - Handle user-defined errors from hash.
551 # TODO - Handle default error messages.
557 my $error = autodie::exception->new(
559 function => "CORE::open",
564 Creates a new C<autodie::exception> object. Normally called
565 directly from an autodying function. The C<function> argument
566 is required, its the function we were trying to call that
567 generated the exception. The C<args> parameter is optional.
569 The C<errno> value is optional. In versions of C<autodie::exception>
570 1.99 and earlier the code would try to automatically use the
571 current value of C<$!>, but this was unreliable and is no longer
574 Atrributes such as package, file, and caller are determined
575 automatically, and cannot be specified.
580 my ($class, @args) = @_;
586 # I'd love to use EVERY here, but it causes our code to die
587 # because it wants to stringify our objects before they're
588 # initialised, causing everything to explode.
597 my ($this, %args) = @_;
599 # Capturing errno here is not necessarily reliable.
600 my $original_errno = $!;
602 our $init_called = 1;
604 my $class = ref $this;
606 # We're going to walk up our call stack, looking for the
607 # first thing that doesn't look like our exception
608 # code, autodie/Fatal, or some whacky eval.
610 my ($package, $file, $line, $sub);
617 ($package, $file, $line, $sub) = CORE::caller($depth);
619 # Skip up the call stack until we find something outside
620 # of the Fatal/autodie/eval space.
622 next if $package->isa('Fatal');
623 next if $package->isa($class);
624 next if $package->isa(__PACKAGE__);
625 next if $file =~ /^\(eval\s\d+\)$/;
631 $this->{$PACKAGE}{package} = $package;
632 $this->{$PACKAGE}{file} = $file;
633 $this->{$PACKAGE}{line} = $line;
634 $this->{$PACKAGE}{caller} = $sub;
635 $this->{$PACKAGE}{package} = $package;
637 $this->{$PACKAGE}{errno} = $args{errno} || 0;
639 $this->{$PACKAGE}{args} = $args{args} || [];
640 $this->{$PACKAGE}{function}= $args{function} or
641 croak("$class->new() called without function arg");
653 L<autodie>, L<autodie::exception::system>
657 Copyright (C)2008 Paul Fenwick
659 This is free software. You may modify and/or redistribute this
660 code under the same terms as Perl 5.10 itself, or, at your option,
661 any later version of Perl 5.
665 Paul Fenwick E<lt>pjf@perltraining.com.auE<gt>