878 lines
22 KiB
Perl
878 lines
22 KiB
Perl
package autodie::exception;
|
|
use 5.008;
|
|
use strict;
|
|
use warnings;
|
|
use Carp qw(croak);
|
|
|
|
our $VERSION = '2.29002';
|
|
# 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<autodie> enabled function fails, it generates an
|
|
C<autodie::exception> 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<autodie::exception>.
|
|
|
|
=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<myscript.pl> or
|
|
C<MyTest.pm>).
|
|
|
|
=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<called> 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<autodie> 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<chown>), 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<NOTE>: This method will leave the main C<autodie::exception> class
|
|
and become part of a role in the future. You should only call
|
|
C<errno> 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<Text::Balanced> 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<matches> 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<MyModule::log>. If the string does not contain a package name,
|
|
C<CORE::> is assumed.
|
|
|
|
=item *
|
|
|
|
For a string that does start with a colon, if the subroutine
|
|
throwing the exception I<does> that behaviour. For example, the
|
|
C<CORE::open> subroutine does C<:file>, C<:io> and C<:all>.
|
|
|
|
See L<autodie/CATEGORIES> for further information.
|
|
|
|
On Perl 5.10 and above, using smart-match (C<~~>) with an
|
|
C<autodie::exception> object will use C<matches> 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<autodie::exception> object; it is no more capable than an explicit
|
|
call to the C<matches> 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<autodie::exception>,
|
|
write code that registers custom error messages, or otherwise
|
|
work closely with the C<autodie::exception> 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 = '<BUFFER>';
|
|
}
|
|
} else {
|
|
$arg_name = '<UNDEF>';
|
|
}
|
|
$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 = '<undef>' 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<register> 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<autodie::exception>
|
|
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<autodie::exception> 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<without using any registered message handlers>. 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<autodie::exception> object. Normally called
|
|
directly from an autodying function. The C<function> argument
|
|
is required, its the function we were trying to call that
|
|
generated the exception. The C<args> parameter is optional.
|
|
|
|
The C<errno> value is optional. In versions of C<autodie::exception>
|
|
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<autodie>, L<autodie::exception::system>
|
|
|
|
=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 E<lt>pjf@perltraining.com.auE<gt>
|