package autodie::exception; use 5.008; use strict; use warnings; use Carp qw(croak); our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying functions. our $DEBUG = 0; use overload q{""} => "stringify", # Overload smart-match only if we're using 5.10 or up ($] >= 5.010 ? ('~~' => "matches") : ()), fallback => 1 ; my $PACKAGE = __PACKAGE__; # Useful to have a scalar for hash keys. =head1 NAME autodie::exception - Exceptions from autodying functions. =head1 SYNOPSIS eval { use autodie; open(my $fh, '<', 'some_file.txt'); ... }; if (my $E = $@) { say "Ooops! ",$E->caller," had problems: $@"; } =head1 DESCRIPTION When an L enabled function fails, it generates an C object. This can be interrogated to determine further information about the error that occurred. This document is broken into two sections; those methods that are most useful to the end-developer, and those methods for anyone wishing to subclass or get very familiar with C. =head2 Common Methods These methods are intended to be used in the everyday dealing of exceptions. The following assume that the error has been copied into a separate scalar: if ($E = $@) { ... } This is not required, but is recommended in case any code is called which may reset or alter C<$@>. =cut =head3 args my $array_ref = $E->args; Provides a reference to the arguments passed to the subroutine that died. =cut sub args { return $_[0]->{$PACKAGE}{args}; } =head3 function my $sub = $E->function; The subroutine (including package) that threw the exception. =cut sub function { return $_[0]->{$PACKAGE}{function}; } =head3 file my $file = $E->file; The file in which the error occurred (eg, C or C). =cut sub file { return $_[0]->{$PACKAGE}{file}; } =head3 package my $package = $E->package; The package from which the exceptional subroutine was called. =cut sub package { return $_[0]->{$PACKAGE}{package}; } =head3 caller my $caller = $E->caller; The subroutine that I the exceptional code. =cut sub caller { return $_[0]->{$PACKAGE}{caller}; } =head3 line my $line = $E->line; The line in C<< $E->file >> where the exceptional code was called. =cut sub line { return $_[0]->{$PACKAGE}{line}; } =head3 context my $context = $E->context; The context in which the subroutine was called by autodie; usually the same as the context in which you called the autodying subroutine. This can be 'list', 'scalar', or undefined (unknown). It will never be 'void', as C always captures the return value in one way or another. For some core functions that always return a scalar value regardless of their context (eg, C), this may be 'scalar', even if you used a list context. =cut # TODO: The comments above say this can be undefined. Is that actually # the case? (With 'system', perhaps?) sub context { return $_[0]->{$PACKAGE}{context} } =head3 return my $return_value = $E->return; The value(s) returned by the failed subroutine. When the subroutine was called in a list context, this will always be a reference to an array containing the results. When the subroutine was called in a scalar context, this will be the actual scalar returned. =cut sub return { return $_[0]->{$PACKAGE}{return} } =head3 errno my $errno = $E->errno; The value of C<$!> at the time when the exception occurred. B: This method will leave the main C class and become part of a role in the future. You should only call C for exceptions where C<$!> would reasonably have been set on failure. =cut # TODO: Make errno part of a role. It doesn't make sense for # everything. sub errno { return $_[0]->{$PACKAGE}{errno}; } =head3 eval_error my $old_eval_error = $E->eval_error; The contents of C<$@> immediately after autodie triggered an exception. This may be useful when dealing with modules such as L that set (but do not throw) C<$@> on error. =cut sub eval_error { return $_[0]->{$PACKAGE}{eval_error}; } =head3 matches if ( $e->matches('open') ) { ... } if ( 'open' ~~ $e ) { ... } C is used to determine whether a given exception matches a particular role. An exception is considered to match a string if: =over 4 =item * For a string not starting with a colon, the string exactly matches the package and subroutine that threw the exception. For example, C. If the string does not contain a package name, C is assumed. =item * For a string that does start with a colon, if the subroutine throwing the exception I that behaviour. For example, the C subroutine does C<:file>, C<:io> and C<:all>. See L for further information. On Perl 5.10 and above, using smart-match (C<~~>) with an C object will use C underneath. This module used to recommend using smart-match with the exception object on the left hand side, but in future Perls that is likely to stop working. The smart-match facility of this class should only be used with the exception object on the right hand side. Having the exception object on the right is both future-proof and portable to older Perls, back to 5.10. Beware that this facility can only be relied upon when it is certain that the exception object actually is an C object; it is no more capable than an explicit call to the C method. =back =cut { my (%cache); sub matches { my ($this, $that) = @_; # TODO - Handle references croak "UNIMPLEMENTED" if ref $that; my $sub = $this->function; if ($DEBUG) { my $sub2 = $this->function; warn "Smart-matching $that against $sub / $sub2\n"; } # Direct subname match. return 1 if $that eq $sub; return 1 if $that !~ /:/ and "CORE::$that" eq $sub; return 0 if $that !~ /^:/; # Cached match / check tags. require Fatal; if (exists $cache{$sub}{$that}) { return $cache{$sub}{$that}; } # This rather awful looking line checks to see if our sub is in the # list of expanded tags, caches it, and returns the result. return $cache{$sub}{$that} = grep { $_ eq $sub } @{ $this->_expand_tag($that) }; } } # This exists primarily so that child classes can override or # augment it if they wish. sub _expand_tag { my ($this, @args) = @_; return Fatal->_expand_tag(@args); } =head2 Advanced methods The following methods, while usable from anywhere, are primarily intended for developers wishing to subclass C, write code that registers custom error messages, or otherwise work closely with the C model. =cut # The table below records customer formatters. # TODO - Should this be a package var instead? # TODO - Should these be in a completely different file, or # perhaps loaded on demand? Most formatters will never # get used in most programs. my %formatter_of = ( 'CORE::close' => \&_format_close, 'CORE::open' => \&_format_open, 'CORE::dbmopen' => \&_format_dbmopen, 'CORE::flock' => \&_format_flock, 'CORE::read' => \&_format_readwrite, 'CORE::sysread' => \&_format_readwrite, 'CORE::syswrite' => \&_format_readwrite, 'CORE::chmod' => \&_format_chmod, 'CORE::mkdir' => \&_format_mkdir, ); sub _beautify_arguments { shift @_; # Walk through all our arguments, and... # # * Replace undef with the word 'undef' # * Replace globs with the string '$fh' # * Quote all other args. foreach my $arg (@_) { if (not defined($arg)) { $arg = 'undef' } elsif (ref($arg) eq "GLOB") { $arg = '$fh' } else { $arg = qq{'$arg'} } } return @_; } sub _trim_package_name { # Info: The following is done since 05/2008 (which is before v1.10) # TODO: This is probably a good idea for CORE, is it # a good idea for other subs? # Trim package name off dying sub for error messages (my $name = $_[1]) =~ s/.*:://; return $name; } # Returns the parameter formatted as octal number sub _octalize_number { my $number = $_[1]; # Only reformat if it looks like a whole number if ($number =~ /^\d+$/) { $number = sprintf("%#04lo", $number); } return $number; } # TODO: Our tests only check LOCK_EX | LOCK_NB is properly # formatted. Try other combinations and ensure they work # correctly. sub _format_flock { my ($this) = @_; require Fcntl; my $filehandle = $this->args->[0]; my $raw_mode = $this->args->[1]; my $mode_type; my $lock_unlock; if ($raw_mode & Fcntl::LOCK_EX() ) { $lock_unlock = "lock"; $mode_type = "for exclusive access"; } elsif ($raw_mode & Fcntl::LOCK_SH() ) { $lock_unlock = "lock"; $mode_type = "for shared access"; } elsif ($raw_mode & Fcntl::LOCK_UN() ) { $lock_unlock = "unlock"; $mode_type = ""; } else { # I've got no idea what they're trying to do. $lock_unlock = "lock"; $mode_type = "with mode $raw_mode"; } my $cooked_filehandle; if ($filehandle and not ref $filehandle) { # A package filehandle with a name! $cooked_filehandle = " $filehandle"; } else { # Otherwise we have a scalar filehandle. $cooked_filehandle = ''; } local $! = $this->errno; return "Can't $lock_unlock filehandle$cooked_filehandle $mode_type: $!"; } # Default formatter for CORE::chmod sub _format_chmod { my ($this) = @_; my @args = @{$this->args}; my $mode = shift @args; local $! = $this->errno; $mode = $this->_octalize_number($mode); @args = $this->_beautify_arguments(@args); return "Can't chmod($mode, ". join(q{, }, @args) ."): $!"; } # Default formatter for CORE::mkdir sub _format_mkdir { my ($this) = @_; my @args = @{$this->args}; # If no mask is specified use default formatter if (@args < 2) { return $this->format_default; } my $file = $args[0]; my $mask = $args[1]; local $! = $this->errno; $mask = $this->_octalize_number($mask); return "Can't mkdir('$file', $mask): '$!'"; } # Default formatter for CORE::dbmopen sub _format_dbmopen { my ($this) = @_; my @args = @{$this->args}; # TODO: Presently, $args flattens out the (usually empty) hash # which is passed as the first argument to dbmopen. This is # a bug in our args handling code (taking a reference to it would # be better), but for the moment we'll just examine the end of # our arguments list for message formatting. my $mode = $args[-1]; my $file = $args[-2]; $mode = $this->_octalize_number($mode); local $! = $this->errno; return "Can't dbmopen(%hash, '$file', $mode): '$!'"; } # Default formatter for CORE::close sub _format_close { my ($this) = @_; my $close_arg = $this->args->[0]; local $! = $this->errno; # If we've got an old-style filehandle, mention it. if ($close_arg and not ref $close_arg) { return "Can't close filehandle '$close_arg': '$!'"; } # TODO - This will probably produce an ugly error. Test and fix. return "Can't close($close_arg) filehandle: '$!'"; } # Default formatter for CORE::read, CORE::sysread and CORE::syswrite # # Similar to default formatter with the buffer filtered out as it # may contain binary data. sub _format_readwrite { my ($this) = @_; my $call = $this->_trim_package_name($this->function); local $! = $this->errno; # These subs receive the following arguments (in order): # # * FILEHANDLE # * SCALAR (buffer, we do not want to write this) # * LENGTH (optional for syswrite) # * OFFSET (optional for all) my (@args) = @{$this->args}; my $arg_name = $args[1]; if (defined($arg_name)) { if (ref($arg_name)) { my $name = blessed($arg_name) || ref($arg_name); $arg_name = "<${name}>"; } else { $arg_name = ''; } } else { $arg_name = ''; } $args[1] = $arg_name; return "Can't $call(" . join(q{, }, @args) . "): $!"; } # Default formatter for CORE::open use constant _FORMAT_OPEN => "Can't open '%s' for %s: '%s'"; sub _format_open_with_mode { my ($this, $mode, $file, $error) = @_; my $wordy_mode; if ($mode eq '<') { $wordy_mode = 'reading'; } elsif ($mode eq '>') { $wordy_mode = 'writing'; } elsif ($mode eq '>>') { $wordy_mode = 'appending'; } $file = '' if not defined $file; return sprintf _FORMAT_OPEN, $file, $wordy_mode, $error if $wordy_mode; Carp::confess("Internal autodie::exception error: Don't know how to format mode '$mode'."); } sub _format_open { my ($this) = @_; my @open_args = @{$this->args}; # Use the default formatter for single-arg and many-arg open if (@open_args <= 1 or @open_args >= 4) { return $this->format_default; } # For two arg open, we have to extract the mode if (@open_args == 2) { my ($fh, $file) = @open_args; if (ref($fh) eq "GLOB") { $fh = '$fh'; } my ($mode) = $file =~ m{ ^\s* # Spaces before mode ( (?> # Non-backtracking subexp. < # Reading |>>? # Writing/appending ) ) [^&] # Not an ampersand (which means a dup) }x; if (not $mode) { # Maybe it's a 2-arg open without any mode at all? # Detect the most simple case for this, where our # file consists only of word characters. if ( $file =~ m{^\s*\w+\s*$} ) { $mode = '<' } else { # Otherwise, we've got no idea what's going on. # Use the default. return $this->format_default; } } # Localising $! means perl makes it a pretty error for us. local $! = $this->errno; return $this->_format_open_with_mode($mode, $file, $!); } # Here we must be using three arg open. my $file = $open_args[2]; local $! = $this->errno; my $mode = $open_args[1]; local $@; my $msg = eval { $this->_format_open_with_mode($mode, $file, $!); }; return $msg if $msg; # Default message (for pipes and odd things) return "Can't open '$file' with mode '$open_args[1]': '$!'"; } =head3 register autodie::exception->register( 'CORE::open' => \&mysub ); The C method allows for the registration of a message handler for a given subroutine. The full subroutine name including the package should be used. Registered message handlers will receive the C object as the first parameter. =cut sub register { my ($class, $symbol, $handler) = @_; croak "Incorrect call to autodie::register" if @_ != 3; $formatter_of{$symbol} = $handler; } =head3 add_file_and_line say "Problem occurred",$@->add_file_and_line; Returns the string C< at %s line %d>, where C<%s> is replaced with the filename, and C<%d> is replaced with the line number. Primarily intended for use by format handlers. =cut # Simply produces the file and line number; intended to be added # to the end of error messages. sub add_file_and_line { my ($this) = @_; return sprintf(" at %s line %d\n", $this->file, $this->line); } =head3 stringify say "The error was: ",$@->stringify; Formats the error as a human readable string. Usually there's no reason to call this directly, as it is used automatically if an C object is ever used as a string. Child classes can override this method to change how they're stringified. =cut sub stringify { my ($this) = @_; my $call = $this->function; my $msg; if ($DEBUG) { my $dying_pkg = $this->package; my $sub = $this->function; my $caller = $this->caller; warn "Stringifing exception for $dying_pkg :: $sub / $caller / $call\n"; } # TODO - This isn't using inheritance. Should it? if ( my $sub = $formatter_of{$call} ) { $msg = $sub->($this) . $this->add_file_and_line; } else { $msg = $this->format_default . $this->add_file_and_line; } $msg .= $this->{$PACKAGE}{_stack_trace} if $Carp::Verbose; return $msg; } =head3 format_default my $error_string = $E->format_default; This produces the default error string for the given exception, I. It is primarily intended to be called from a message handler when they have been passed an exception they don't want to format. Child classes can override this method to change how default messages are formatted. =cut # TODO: This produces ugly errors. Is there any way we can # dig around to find the actual variable names? I know perl 5.10 # does some dark and terrible magicks to find them for undef warnings. sub format_default { my ($this) = @_; my $call = $this->_trim_package_name($this->function); local $! = $this->errno; my @args = @{ $this->args() }; @args = $this->_beautify_arguments(@args); # Format our beautiful error. return "Can't $call(". join(q{, }, @args) . "): $!" ; # TODO - Handle user-defined errors from hash. # TODO - Handle default error messages. } =head3 new my $error = autodie::exception->new( args => \@_, function => "CORE::open", errno => $!, context => 'scalar', return => undef, ); Creates a new C object. Normally called directly from an autodying function. The C argument is required, its the function we were trying to call that generated the exception. The C parameter is optional. The C value is optional. In versions of C 1.99 and earlier the code would try to automatically use the current value of C<$!>, but this was unreliable and is no longer supported. Atrributes such as package, file, and caller are determined automatically, and cannot be specified. =cut sub new { my ($class, @args) = @_; my $this = {}; bless($this,$class); # I'd love to use EVERY here, but it causes our code to die # because it wants to stringify our objects before they're # initialised, causing everything to explode. $this->_init(@args); return $this; } sub _init { my ($this, %args) = @_; # Capturing errno here is not necessarily reliable. my $original_errno = $!; our $init_called = 1; my $class = ref $this; # We're going to walk up our call stack, looking for the # first thing that doesn't look like our exception # code, autodie/Fatal, or some whacky eval. my ($package, $file, $line, $sub); my $depth = 0; while (1) { $depth++; ($package, $file, $line, $sub) = CORE::caller($depth); # Skip up the call stack until we find something outside # of the Fatal/autodie/eval space. next if $package->isa('Fatal'); next if $package->isa($class); next if $package->isa(__PACKAGE__); # Anything with the 'autodie::skip' role wants us to skip it. # https://github.com/pjf/autodie/issues/15 next if ($package->can('DOES') and $package->DOES('autodie::skip')); next if $file =~ /^\(eval\s\d+\)$/; last; } # We now have everything correct, *except* for our subroutine # name. If it's __ANON__ or (eval), then we need to keep on # digging deeper into our stack to find the real name. However we # don't update our other information, since that will be correct # for our current exception. my $first_guess_subroutine = $sub; while (defined $sub and $sub =~ /^\(eval\)$|::__ANON__$/) { $depth++; $sub = (CORE::caller($depth))[3]; } # If we end up falling out the bottom of our stack, then our # __ANON__ guess is the best we can get. This includes situations # where we were called from the top level of a program. if (not defined $sub) { $sub = $first_guess_subroutine; } $this->{$PACKAGE}{package} = $package; $this->{$PACKAGE}{file} = $file; $this->{$PACKAGE}{line} = $line; $this->{$PACKAGE}{caller} = $sub; # Tranks to %Carp::CarpInternal all Fatal, autodie and # autodie::exception stack frames are filtered already, but our # nameless wrapper is still present, so strip that. my $trace = Carp::longmess(); $trace =~ s/^\s*at \(eval[^\n]+\n//; # And if we see an __ANON__, then we'll replace that with the actual # name of our autodying function. my $short_func = $args{function}; $short_func =~ s/^CORE:://; $trace =~ s/(\s*[\w:]+)__ANON__/$1$short_func/; # And now we just fill in all our attributes. $this->{$PACKAGE}{_stack_trace} = $trace; $this->{$PACKAGE}{errno} = $args{errno} || 0; $this->{$PACKAGE}{context} = $args{context}; $this->{$PACKAGE}{return} = $args{return}; $this->{$PACKAGE}{eval_error} = $args{eval_error}; $this->{$PACKAGE}{args} = $args{args} || []; $this->{$PACKAGE}{function}= $args{function} or croak("$class->new() called without function arg"); return $this; } 1; __END__ =head1 SEE ALSO L, L =head1 LICENSE Copyright (C)2008 Paul Fenwick This is free software. You may modify and/or redistribute this code under the same terms as Perl 5.10 itself, or, at your option, any later version of Perl 5. =head1 AUTHOR Paul Fenwick Epjf@perltraining.com.auE