596 lines
16 KiB
Perl
596 lines
16 KiB
Perl
package Exception::Class::Base;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
our $VERSION = '1.44';
|
|
|
|
use Class::Data::Inheritable 0.02;
|
|
use Devel::StackTrace 2.00;
|
|
use Scalar::Util qw( blessed );
|
|
|
|
use base qw(Class::Data::Inheritable);
|
|
|
|
BEGIN {
|
|
__PACKAGE__->mk_classdata('Trace');
|
|
__PACKAGE__->mk_classdata('UnsafeRefCapture');
|
|
|
|
__PACKAGE__->mk_classdata('NoContextInfo');
|
|
__PACKAGE__->NoContextInfo(0);
|
|
|
|
__PACKAGE__->mk_classdata('RespectOverload');
|
|
__PACKAGE__->RespectOverload(0);
|
|
|
|
__PACKAGE__->mk_classdata('MaxArgLength');
|
|
__PACKAGE__->MaxArgLength(0);
|
|
|
|
sub NoRefs {
|
|
my $self = shift;
|
|
if (@_) {
|
|
my $val = shift;
|
|
return $self->UnsafeRefCapture( !$val );
|
|
}
|
|
else {
|
|
return $self->UnsafeRefCapture;
|
|
}
|
|
}
|
|
|
|
sub Fields { () }
|
|
}
|
|
|
|
use overload
|
|
|
|
# an exception is always true
|
|
bool => sub {1}, '""' => 'as_string', fallback => 1;
|
|
|
|
# Create accessor routines
|
|
BEGIN {
|
|
my @fields = qw( message pid uid euid gid egid time trace );
|
|
|
|
foreach my $f (@fields) {
|
|
my $sub = sub { my $s = shift; return $s->{$f}; };
|
|
|
|
## no critic (TestingAndDebugging::ProhibitNoStrict)
|
|
no strict 'refs';
|
|
*{$f} = $sub;
|
|
}
|
|
*error = \&message;
|
|
|
|
my %trace_fields = (
|
|
package => 'package',
|
|
file => 'filename',
|
|
line => 'line',
|
|
);
|
|
|
|
while ( my ( $f, $m ) = each %trace_fields ) {
|
|
my $sub = sub {
|
|
my $s = shift;
|
|
return $s->{$f} if exists $s->{$f};
|
|
|
|
my $frame = $s->trace->frame(0);
|
|
|
|
return $s->{$f} = $frame ? $frame->$m : undef;
|
|
};
|
|
|
|
## no critic (TestingAndDebugging::ProhibitNoStrict)
|
|
no strict 'refs';
|
|
*{$f} = $sub;
|
|
}
|
|
}
|
|
|
|
sub Classes { Exception::Class::Classes() }
|
|
|
|
sub throw {
|
|
my $proto = shift;
|
|
|
|
$proto->rethrow if ref $proto;
|
|
|
|
die $proto->new(@_);
|
|
}
|
|
|
|
sub rethrow {
|
|
my $self = shift;
|
|
|
|
die $self;
|
|
}
|
|
|
|
sub new {
|
|
my $proto = shift;
|
|
my $class = ref $proto || $proto;
|
|
|
|
my $self = bless {}, $class;
|
|
|
|
$self->_initialize(@_);
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub _initialize {
|
|
my $self = shift;
|
|
my %p = @_ == 1 ? ( error => $_[0] ) : @_;
|
|
|
|
$self->{message} = $p{message} || $p{error} || q{};
|
|
|
|
$self->{show_trace} = $p{show_trace} if exists $p{show_trace};
|
|
|
|
if ( $self->NoContextInfo ) {
|
|
$self->{show_trace} = 0;
|
|
$self->{package} = $self->{file} = $self->{line} = undef;
|
|
}
|
|
else {
|
|
# CORE::time is important to fix an error with some versions of
|
|
# Perl
|
|
$self->{time} = CORE::time();
|
|
$self->{pid} = $$;
|
|
$self->{uid} = $<;
|
|
$self->{euid} = $>;
|
|
$self->{gid} = $(;
|
|
$self->{egid} = $);
|
|
|
|
my @ignore_class = (__PACKAGE__);
|
|
my @ignore_package = 'Exception::Class';
|
|
|
|
if ( my $i = delete $p{ignore_class} ) {
|
|
push @ignore_class, ( ref($i) eq 'ARRAY' ? @$i : $i );
|
|
}
|
|
|
|
if ( my $i = delete $p{ignore_package} ) {
|
|
push @ignore_package, ( ref($i) eq 'ARRAY' ? @$i : $i );
|
|
}
|
|
|
|
$self->{trace} = Devel::StackTrace->new(
|
|
ignore_class => \@ignore_class,
|
|
ignore_package => \@ignore_package,
|
|
unsafe_ref_capture => $self->UnsafeRefCapture,
|
|
respect_overload => $self->RespectOverload,
|
|
max_arg_length => $self->MaxArgLength,
|
|
map { $p{$_} ? ( $_ => delete $p{$_} ) : () } qw(
|
|
frame_filter
|
|
filter_frames_early
|
|
skip_frames
|
|
),
|
|
);
|
|
}
|
|
|
|
my %fields = map { $_ => 1 } $self->Fields;
|
|
while ( my ( $key, $value ) = each %p ) {
|
|
next if $key =~ /^(?:error|message|show_trace)$/;
|
|
|
|
if ( $fields{$key} ) {
|
|
$self->{$key} = $value;
|
|
}
|
|
else {
|
|
Exception::Class::Base->throw(
|
|
error => "unknown field $key passed to constructor for class "
|
|
. ref $self );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub context_hash {
|
|
my $self = shift;
|
|
|
|
return {
|
|
time => $self->{time},
|
|
pid => $self->{pid},
|
|
uid => $self->{uid},
|
|
euid => $self->{euid},
|
|
gid => $self->{gid},
|
|
egid => $self->{egid},
|
|
};
|
|
}
|
|
|
|
sub field_hash {
|
|
my $self = shift;
|
|
|
|
my $hash = {};
|
|
|
|
for my $field ( $self->Fields ) {
|
|
$hash->{$field} = $self->$field;
|
|
}
|
|
|
|
return $hash;
|
|
}
|
|
|
|
sub description {
|
|
return 'Generic exception';
|
|
}
|
|
|
|
sub show_trace {
|
|
my $self = shift;
|
|
|
|
return 0 unless $self->{trace};
|
|
|
|
if (@_) {
|
|
$self->{show_trace} = shift;
|
|
}
|
|
|
|
return exists $self->{show_trace} ? $self->{show_trace} : $self->Trace;
|
|
}
|
|
|
|
sub as_string {
|
|
my $self = shift;
|
|
|
|
my $str = $self->full_message;
|
|
unless ( defined $str && length $str ) {
|
|
my $desc = $self->description;
|
|
$str = defined $desc
|
|
&& length $desc ? "[$desc]" : '[Generic exception]';
|
|
}
|
|
|
|
$str .= "\n\n" . $self->trace->as_string
|
|
if $self->show_trace;
|
|
|
|
return $str;
|
|
}
|
|
|
|
sub full_message { $_[0]->message }
|
|
|
|
#
|
|
# The %seen bit protects against circular inheritance.
|
|
#
|
|
## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
|
|
eval <<'EOF' if $] == 5.006;
|
|
sub isa {
|
|
my ( $inheritor, $base ) = @_;
|
|
$inheritor = ref($inheritor) if ref($inheritor);
|
|
|
|
my %seen;
|
|
|
|
no strict 'refs';
|
|
my @parents = ( $inheritor, @{"$inheritor\::ISA"} );
|
|
while ( my $class = shift @parents ) {
|
|
return 1 if $class eq $base;
|
|
|
|
push @parents, grep { !$seen{$_}++ } @{"$class\::ISA"};
|
|
}
|
|
return 0;
|
|
}
|
|
EOF
|
|
|
|
sub caught {
|
|
my $class = shift;
|
|
|
|
my $e = $@;
|
|
|
|
return unless defined $e && blessed($e) && $e->isa($class);
|
|
return $e;
|
|
}
|
|
|
|
1;
|
|
|
|
# ABSTRACT: A base class for exception objects
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
Exception::Class::Base - A base class for exception objects
|
|
|
|
=head1 VERSION
|
|
|
|
version 1.44
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Exception::Class 'MyException';
|
|
|
|
eval { MyException->throw( error => 'I feel funny.' ) };
|
|
|
|
print $@->error;
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
This class is the base class for all exceptions created by
|
|
L<Exception::Class>. It provides a number of methods for getting information
|
|
about the exception.
|
|
|
|
=for Pod::Coverage Classes
|
|
caught
|
|
NoRefs
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 MyException->Trace($boolean)
|
|
|
|
Each C<Exception::Class::Base> subclass can be set individually to include a
|
|
stacktrace when the C<as_string> method is called. The default is to not
|
|
include a stacktrace. Calling this method with a value changes this
|
|
behavior. It always returns the current value (after any change is applied).
|
|
|
|
This value is inherited by any subclasses. However, if this value is set for a
|
|
subclass, it will thereafter be independent of the value in
|
|
C<Exception::Class::Base>.
|
|
|
|
Do not call this on the C<Exception::Class::Base> class directly or you'll
|
|
change it for all exception classes that use L<Exception::Class>, including
|
|
ones created in modules you don't control.
|
|
|
|
This is a class method, not an object method.
|
|
|
|
=head2 MyException->UnsafeRefCapture($boolean)
|
|
|
|
When a C<Devel::StackTrace> object is created, it walks through the stack and
|
|
stores the arguments which were passed to each subroutine on the stack. If any
|
|
of these arguments are references, then that means that the
|
|
C<Devel::StackTrace> ends up increasing the ref count of these references,
|
|
delaying their destruction.
|
|
|
|
Since C<Exception::Class::Base> uses C<Devel::StackTrace> internally, this
|
|
method provides a way to tell C<Devel::StackTrace> not to store these
|
|
references. Instead, C<Devel::StackTrace> replaces references with their
|
|
stringified representation.
|
|
|
|
This method defaults to false. As with C<Trace>, it is inherited by subclasses
|
|
but setting it in a subclass makes it independent thereafter.
|
|
|
|
Do not call this on the C<Exception::Class::Base> class directly or you'll
|
|
change it for all exception classes that use L<Exception::Class>, including
|
|
ones created in modules you don't control.
|
|
|
|
=head2 MyException->RespectOverload($boolean)
|
|
|
|
When a C<Devel::StackTrace> object stringifies, by default it ignores
|
|
stringification overloading on any objects being dealt with.
|
|
|
|
Since C<Exception::Class::Base> uses C<Devel::StackTrace> internally, this
|
|
method provides a way to tell C<Devel::StackTrace> to respect overloading.
|
|
|
|
This method defaults to false. As with C<Trace>, it is inherited by subclasses
|
|
but setting it in a subclass makes it independent thereafter.
|
|
|
|
Do not call this on the C<Exception::Class::Base> class directly or you'll
|
|
change it for all exception classes that use L<Exception::Class>, including
|
|
ones created in modules you don't control.
|
|
|
|
=head2 MyException->MaxArgLength($boolean)
|
|
|
|
When a C<Devel::StackTrace> object stringifies, by default it displays the
|
|
full argument for each function. This parameter can be used to limit the
|
|
maximum length of each argument.
|
|
|
|
Since C<Exception::Class::Base> uses C<Devel::StackTrace> internally, this
|
|
method provides a way to tell C<Devel::StackTrace> to limit the length of
|
|
arguments.
|
|
|
|
This method defaults to 0. As with C<Trace>, it is inherited by subclasses but
|
|
setting it in a subclass makes it independent thereafter.
|
|
|
|
Do not call this on the C<Exception::Class::Base> class directly or you'll
|
|
change it for all exception classes that use L<Exception::Class>, including
|
|
ones created in modules you don't control.
|
|
|
|
=head2 MyException->Fields
|
|
|
|
This method returns the extra fields defined for the given class, as a list.
|
|
|
|
Do not call this on the C<Exception::Class::Base> class directly or you'll
|
|
change it for all exception classes that use L<Exception::Class>, including
|
|
ones created in modules you don't control.
|
|
|
|
=head2 MyException->throw( $message )
|
|
|
|
=head2 MyException->throw( message => $message )
|
|
|
|
=head2 MyException->throw( error => $error )
|
|
|
|
This method creates a new object with the given error message. If no error
|
|
message is given, this will be an empty string. It then dies with this object
|
|
as its argument.
|
|
|
|
This method also takes a C<show_trace> parameter which indicates whether or
|
|
not the particular exception object being created should show a stacktrace
|
|
when its C<as_string> method is called. This overrides the value of C<Trace>
|
|
for this class if it is given.
|
|
|
|
The frames included in the trace can be controlled by the C<ignore_class> and
|
|
C<ignore_package> parameters. These are passed directly to Devel::Stacktrace's
|
|
constructor. See C<Devel::Stacktrace> for more details. This class B<always>
|
|
passes C<__PACKAGE__> for C<ignore_class> and C<'Exception::Class'> for
|
|
C<ignore_package>, in addition to any arguments you provide.
|
|
|
|
If only a single value is given to the constructor it is assumed to be the
|
|
message parameter.
|
|
|
|
Additional keys corresponding to the fields defined for the particular
|
|
exception subclass will also be accepted.
|
|
|
|
=head2 MyException->new(...)
|
|
|
|
This method takes the same parameters as C<throw>, but instead of dying simply
|
|
returns a new exception object.
|
|
|
|
This method is always called when constructing a new exception object via the
|
|
C<throw> method.
|
|
|
|
=head2 MyException->description
|
|
|
|
Returns the description for the given C<Exception::Class::Base> subclass. The
|
|
C<Exception::Class::Base> class's description is "Generic exception" (this may
|
|
change in the future). This is also an object method.
|
|
|
|
=head2 $exception->rethrow
|
|
|
|
Simply dies with the object as its sole argument. It's just syntactic
|
|
sugar. This does not change any of the object's attribute values. However, it
|
|
will cause C<caller> to report the die as coming from within the
|
|
C<Exception::Class::Base> class rather than where rethrow was called.
|
|
|
|
Of course, you always have access to the original stacktrace for the exception
|
|
object.
|
|
|
|
=head2 $exception->message
|
|
|
|
=head2 $exception->error
|
|
|
|
Returns the error/message associated with the exception.
|
|
|
|
=head2 $exception->pid
|
|
|
|
Returns the pid at the time the exception was thrown.
|
|
|
|
=head2 $exception->uid
|
|
|
|
Returns the real user id at the time the exception was thrown.
|
|
|
|
=head2 $exception->gid
|
|
|
|
Returns the real group id at the time the exception was thrown.
|
|
|
|
=head2 $exception->euid
|
|
|
|
Returns the effective user id at the time the exception was thrown.
|
|
|
|
=head2 $exception->egid
|
|
|
|
Returns the effective group id at the time the exception was thrown.
|
|
|
|
=head2 $exception->time
|
|
|
|
Returns the time in seconds since the epoch at the time the exception was
|
|
thrown.
|
|
|
|
=head2 $exception->package
|
|
|
|
Returns the package from which the exception was thrown.
|
|
|
|
=head2 $exception->file
|
|
|
|
Returns the file within which the exception was thrown.
|
|
|
|
=head2 $exception->line
|
|
|
|
Returns the line where the exception was thrown.
|
|
|
|
=head2 $exception->context_hash
|
|
|
|
Returns a hash reference with the following keys:
|
|
|
|
=over 4
|
|
|
|
=item * time
|
|
|
|
=item * pid
|
|
|
|
=item * uid
|
|
|
|
=item * euid
|
|
|
|
=item * gid
|
|
|
|
=item * egid
|
|
|
|
=back
|
|
|
|
=head2 $exception->field_hash
|
|
|
|
Returns a hash reference where the keys are any fields defined for the
|
|
exception class and the values are the values associated with the field in the
|
|
given object.
|
|
|
|
=head2 $exception->trace
|
|
|
|
Returns the trace object associated with the object.
|
|
|
|
=head2 $exception->show_trace($boolean)
|
|
|
|
This method can be used to set whether or not a stack trace is included when
|
|
the as_string method is called or the object is stringified.
|
|
|
|
=head2 $exception->as_string
|
|
|
|
Returns a string form of the error message (something like what you'd expect
|
|
from die). If the class or object is set to show traces then then the full
|
|
trace is also included. The result looks like C<Carp::confess>.
|
|
|
|
=head2 $exception->full_message
|
|
|
|
Called by the C<as_string> method to get the message. By default, this is the
|
|
same as calling the C<message> method, but may be overridden by a
|
|
subclass. See below for details.
|
|
|
|
=head1 LIGHTWEIGHT EXCEPTIONS
|
|
|
|
A lightweight exception is one which records no information about its context
|
|
when it is created. This can be achieved by setting C<< $class->NoContextInfo
|
|
>> to a true value.
|
|
|
|
You can make this the default for a class of exceptions by setting it after
|
|
creating the class:
|
|
|
|
use Exception::Class (
|
|
'LightWeight',
|
|
'HeavyWeight',
|
|
);
|
|
|
|
LightWeight->NoContextInfo(1);
|
|
|
|
A lightweight exception does have a stack trace object, nor does it record the
|
|
time, pid, uid, euid, gid, or egid. It only has a message.
|
|
|
|
=head1 OVERLOADING
|
|
|
|
C<Exception::Class::Base> objects are overloaded so that stringification
|
|
produces a normal error message. This just calls the C<< $exception->as_string
|
|
>> method described above. This means that you can just C<print $@> after an
|
|
C<eval> and not worry about whether or not its an actual object. It also means
|
|
an application or module could do this:
|
|
|
|
$SIG{__DIE__} = sub { Exception::Class::Base->throw( error => join '', @_ ); };
|
|
|
|
and this would probably not break anything (unless someone was expecting a
|
|
different type of exception object from C<die>).
|
|
|
|
=head1 OVERRIDING THE as_string METHOD
|
|
|
|
By default, the C<as_string> method simply returns the value C<message> or
|
|
C<error> param plus a stack trace, if the class's C<Trace> method returns a
|
|
true value or C<show_trace> was set when creating the exception.
|
|
|
|
However, once you add new fields to a subclass, you may want to include those
|
|
fields in the stringified error.
|
|
|
|
Inside the C<as_string> method, the message (non-stack trace) portion of the
|
|
error is generated by calling the C<full_message> method. This can be easily
|
|
overridden. For example:
|
|
|
|
sub full_message {
|
|
my $self = shift;
|
|
|
|
my $msg = $self->message;
|
|
|
|
$msg .= " and foo was " . $self->foo;
|
|
|
|
return $msg;
|
|
}
|
|
|
|
=head1 SUPPORT
|
|
|
|
Bugs may be submitted at L<https://github.com/houseabsolute/Exception-Class/issues>.
|
|
|
|
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
|
|
|
|
=head1 SOURCE
|
|
|
|
The source code repository for Exception-Class can be found at L<https://github.com/houseabsolute/Exception-Class>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Dave Rolsky <autarch@urth.org>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
This software is copyright (c) 2017 by Dave Rolsky.
|
|
|
|
This is free software; you can redistribute it and/or modify it under
|
|
the same terms as the Perl 5 programming language system itself.
|
|
|
|
The full text of the license can be found in the
|
|
F<LICENSE> file included with this distribution.
|
|
|
|
=cut
|