Initial Commit
This commit is contained in:
Riley Schneider
569
database/perl/vendor/lib/Exception/Class.pm
vendored
Normal file
569
database/perl/vendor/lib/Exception/Class.pm
vendored
Normal file
@@ -0,0 +1,569 @@
|
||||
package Exception::Class;
|
||||
|
||||
use 5.008001;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.44';
|
||||
|
||||
use Exception::Class::Base;
|
||||
use Scalar::Util qw( blessed reftype );
|
||||
|
||||
our $BASE_EXC_CLASS;
|
||||
BEGIN { $BASE_EXC_CLASS ||= 'Exception::Class::Base'; }
|
||||
|
||||
our %CLASSES;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
## no critic (Variables::ProhibitPackageVars)
|
||||
local $Exception::Class::Caller = caller();
|
||||
|
||||
my %c;
|
||||
|
||||
my %needs_parent;
|
||||
while ( my $subclass = shift ) {
|
||||
my $def = ref $_[0] ? shift : {};
|
||||
$def->{isa}
|
||||
= $def->{isa}
|
||||
? ( ref $def->{isa} ? $def->{isa} : [ $def->{isa} ] )
|
||||
: [];
|
||||
|
||||
$c{$subclass} = $def;
|
||||
}
|
||||
|
||||
# We need to sort by length because if we check for keys in the
|
||||
# Foo::Bar:: stash, this creates a "Bar::" key in the Foo:: stash!
|
||||
MAKE_CLASSES:
|
||||
foreach my $subclass ( sort { length $a <=> length $b } keys %c ) {
|
||||
my $def = $c{$subclass};
|
||||
|
||||
# We already made this one.
|
||||
next if $CLASSES{$subclass};
|
||||
|
||||
{
|
||||
## no critic (TestingAndDebugging::ProhibitNoStrict)
|
||||
no strict 'refs';
|
||||
foreach my $parent ( @{ $def->{isa} } ) {
|
||||
unless ( keys %{"$parent\::"} ) {
|
||||
$needs_parent{$subclass} = {
|
||||
parents => $def->{isa},
|
||||
def => $def
|
||||
};
|
||||
next MAKE_CLASSES;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$class->_make_subclass(
|
||||
subclass => $subclass,
|
||||
def => $def || {},
|
||||
);
|
||||
}
|
||||
|
||||
foreach my $subclass ( keys %needs_parent ) {
|
||||
|
||||
# This will be used to spot circular references.
|
||||
my %seen;
|
||||
$class->_make_parents( \%needs_parent, $subclass, \%seen );
|
||||
}
|
||||
}
|
||||
|
||||
sub _make_parents {
|
||||
my $class = shift;
|
||||
my $needs = shift;
|
||||
my $subclass = shift;
|
||||
my $seen = shift;
|
||||
my $child = shift; # Just for error messages.
|
||||
|
||||
## no critic (TestingAndDebugging::ProhibitNoStrict, TestingAndDebugging::ProhibitProlongedStrictureOverride)
|
||||
no strict 'refs';
|
||||
|
||||
# What if someone makes a typo in specifying their 'isa' param?
|
||||
# This should catch it. Either it's been made because it didn't
|
||||
# have missing parents OR it's in our hash as needing a parent.
|
||||
# If neither of these is true then the _only_ place it is
|
||||
# mentioned is in the 'isa' param for some other class, which is
|
||||
# not a good enough reason to make a new class.
|
||||
die
|
||||
"Class $subclass appears to be a typo as it is only specified in the 'isa' param for $child\n"
|
||||
unless exists $needs->{$subclass}
|
||||
|| $CLASSES{$subclass}
|
||||
|| keys %{"$subclass\::"};
|
||||
|
||||
foreach my $c ( @{ $needs->{$subclass}{parents} } ) {
|
||||
|
||||
# It's been made
|
||||
next if $CLASSES{$c} || keys %{"$c\::"};
|
||||
|
||||
die "There appears to be some circularity involving $subclass\n"
|
||||
if $seen->{$subclass};
|
||||
|
||||
$seen->{$subclass} = 1;
|
||||
|
||||
$class->_make_parents( $needs, $c, $seen, $subclass );
|
||||
}
|
||||
|
||||
return if $CLASSES{$subclass} || keys %{"$subclass\::"};
|
||||
|
||||
$class->_make_subclass(
|
||||
subclass => $subclass,
|
||||
def => $needs->{$subclass}{def}
|
||||
);
|
||||
}
|
||||
|
||||
sub _make_subclass {
|
||||
my $class = shift;
|
||||
my %p = @_;
|
||||
|
||||
my $subclass = $p{subclass};
|
||||
my $def = $p{def};
|
||||
|
||||
my $isa;
|
||||
if ( $def->{isa} ) {
|
||||
$isa = ref $def->{isa} ? join q{ }, @{ $def->{isa} } : $def->{isa};
|
||||
}
|
||||
$isa ||= $BASE_EXC_CLASS;
|
||||
|
||||
my $version_name = 'VERSION';
|
||||
|
||||
my $code = <<"EOPERL";
|
||||
package $subclass;
|
||||
|
||||
use base qw($isa);
|
||||
|
||||
our \$$version_name = '1.1';
|
||||
|
||||
1;
|
||||
|
||||
EOPERL
|
||||
|
||||
if ( $def->{description} ) {
|
||||
( my $desc = $def->{description} ) =~ s/([\\\'])/\\$1/g;
|
||||
$code .= <<"EOPERL";
|
||||
sub description
|
||||
{
|
||||
return '$desc';
|
||||
}
|
||||
EOPERL
|
||||
}
|
||||
|
||||
my @fields;
|
||||
if ( my $fields = $def->{fields} ) {
|
||||
@fields
|
||||
= ref $fields && reftype $fields eq 'ARRAY' ? @$fields : $fields;
|
||||
|
||||
$code
|
||||
.= 'sub Fields { return ($_[0]->SUPER::Fields, '
|
||||
. join( ', ', map {"'$_'"} @fields )
|
||||
. ") }\n\n";
|
||||
|
||||
foreach my $field (@fields) {
|
||||
$code .= sprintf( "sub %s { \$_[0]->{%s} }\n", $field, $field );
|
||||
}
|
||||
}
|
||||
|
||||
if ( my $alias = $def->{alias} ) {
|
||||
## no critic (Variables::ProhibitPackageVars)
|
||||
die 'Cannot make alias without caller'
|
||||
unless defined $Exception::Class::Caller;
|
||||
|
||||
## no critic (TestingAndDebugging::ProhibitNoStrict)
|
||||
no strict 'refs';
|
||||
*{"$Exception::Class::Caller\::$alias"}
|
||||
= sub { $subclass->throw(@_) };
|
||||
}
|
||||
|
||||
if ( my $defaults = $def->{defaults} ) {
|
||||
$code
|
||||
.= "sub _defaults { return shift->SUPER::_defaults, our \%_DEFAULTS }\n";
|
||||
## no critic (TestingAndDebugging::ProhibitNoStrict)
|
||||
no strict 'refs';
|
||||
*{"$subclass\::_DEFAULTS"} = {%$defaults};
|
||||
}
|
||||
|
||||
## no critic (BuiltinFunctions::ProhibitStringyEval, ErrorHandling::RequireCheckingReturnValueOfEval)
|
||||
eval $code;
|
||||
die $@ if $@;
|
||||
|
||||
( my $filename = "$subclass.pm" ) =~ s{::}{/}g;
|
||||
$INC{$filename} = __FILE__;
|
||||
|
||||
$CLASSES{$subclass} = 1;
|
||||
}
|
||||
|
||||
sub caught {
|
||||
my $e = $@;
|
||||
|
||||
return $e unless $_[1];
|
||||
|
||||
return unless blessed($e) && $e->isa( $_[1] );
|
||||
return $e;
|
||||
}
|
||||
|
||||
sub Classes { sort keys %Exception::Class::CLASSES }
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: A module that allows you to declare real exception classes in Perl
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Exception::Class - A module that allows you to declare real exception classes in Perl
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 1.44
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Exception::Class (
|
||||
'MyException',
|
||||
|
||||
'AnotherException' => { isa => 'MyException' },
|
||||
|
||||
'YetAnotherException' => {
|
||||
isa => 'AnotherException',
|
||||
description => 'These exceptions are related to IPC'
|
||||
},
|
||||
|
||||
'ExceptionWithFields' => {
|
||||
isa => 'YetAnotherException',
|
||||
fields => [ 'grandiosity', 'quixotic' ],
|
||||
alias => 'throw_fields',
|
||||
},
|
||||
);
|
||||
use Scalar::Util qw( blessed );
|
||||
use Try::Tiny;
|
||||
|
||||
try {
|
||||
MyException->throw( error => 'I feel funny.' );
|
||||
}
|
||||
catch {
|
||||
die $_ unless blessed $_ && $_->can('rethrow');
|
||||
|
||||
if ( $_->isa('Exception::Class') ) {
|
||||
warn $_->error, "\n", $_->trace->as_string, "\n";
|
||||
warn join ' ', $_->euid, $_->egid, $_->uid, $_->gid, $_->pid, $_->time;
|
||||
|
||||
exit;
|
||||
}
|
||||
elsif ( $_->isa('ExceptionWithFields') ) {
|
||||
if ( $_->quixotic ) {
|
||||
handle_quixotic_exception();
|
||||
}
|
||||
else {
|
||||
handle_non_quixotic_exception();
|
||||
}
|
||||
}
|
||||
else {
|
||||
$_->rethrow;
|
||||
}
|
||||
};
|
||||
|
||||
# without Try::Tiny
|
||||
eval { ... };
|
||||
if ( my $e = Exception::Class->caught ) { ... }
|
||||
|
||||
# use an alias - without parens subroutine name is checked at
|
||||
# compile time
|
||||
throw_fields error => "No strawberry", grandiosity => "quite a bit";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<RECOMMENDATION 1>: If you are writing modern Perl code with L<Moose> or
|
||||
L<Moo> I highly recommend using L<Throwable> instead of this module.
|
||||
|
||||
B<RECOMMENDATION 2>: Whether or not you use L<Throwable>, you should use
|
||||
L<Try::Tiny>.
|
||||
|
||||
Exception::Class allows you to declare exception hierarchies in your modules
|
||||
in a "Java-esque" manner.
|
||||
|
||||
It features a simple interface allowing programmers to 'declare' exception
|
||||
classes at compile time. It also has a base exception class,
|
||||
L<Exception::Class::Base>, that can be easily extended.
|
||||
|
||||
It is designed to make structured exception handling simpler and better by
|
||||
encouraging people to use hierarchies of exceptions in their applications, as
|
||||
opposed to a single catch-all exception class.
|
||||
|
||||
This module does not implement any try/catch syntax. Please see the "OTHER
|
||||
EXCEPTION MODULES (try/catch syntax)" section for more information on how to
|
||||
get this syntax.
|
||||
|
||||
You will also want to look at the documentation for L<Exception::Class::Base>,
|
||||
which is the default base class for all exception objects created by this
|
||||
module.
|
||||
|
||||
=for Pod::Coverage Classes
|
||||
caught
|
||||
|
||||
=head1 DECLARING EXCEPTION CLASSES
|
||||
|
||||
Importing C<Exception::Class> allows you to automagically create
|
||||
L<Exception::Class::Base> subclasses. You can also create subclasses via the
|
||||
traditional means of defining your own subclass with C<@ISA>. These two
|
||||
methods may be easily combined, so that you could subclass an exception class
|
||||
defined via the automagic import, if you desired this.
|
||||
|
||||
The syntax for the magic declarations is as follows:
|
||||
|
||||
'MANDATORY CLASS NAME' => \%optional_hashref
|
||||
|
||||
The hashref may contain the following options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * isa
|
||||
|
||||
This is the class's parent class. If this isn't provided then the class name
|
||||
in C<$Exception::Class::BASE_EXC_CLASS> is assumed to be the parent (see
|
||||
below).
|
||||
|
||||
This parameter lets you create arbitrarily deep class hierarchies. This can
|
||||
be any other L<Exception::Class::Base> subclass in your declaration I<or> a
|
||||
subclass loaded from a module.
|
||||
|
||||
To change the default exception class you will need to change the value of
|
||||
C<$Exception::Class::BASE_EXC_CLASS> I<before> calling C<import>. To do this
|
||||
simply do something like this:
|
||||
|
||||
BEGIN { $Exception::Class::BASE_EXC_CLASS = 'SomeExceptionClass'; }
|
||||
|
||||
If anyone can come up with a more elegant way to do this please let me know.
|
||||
|
||||
CAVEAT: If you want to automagically subclass an L<Exception::Class::Base>
|
||||
subclass loaded from a file, then you I<must> compile the class (via use or
|
||||
require or some other magic) I<before> you import C<Exception::Class> or
|
||||
you'll get a compile time error.
|
||||
|
||||
=item * fields
|
||||
|
||||
This allows you to define additional attributes for your exception class. Any
|
||||
field you define can be passed to the C<throw> or C<new> methods as additional
|
||||
parameters for the constructor. In addition, your exception object will have
|
||||
an accessor method for the fields you define.
|
||||
|
||||
This parameter can be either a scalar (for a single field) or an array
|
||||
reference if you need to define multiple fields.
|
||||
|
||||
Fields will be inherited by subclasses.
|
||||
|
||||
=item * alias
|
||||
|
||||
Specifying an alias causes this class to create a subroutine of the specified
|
||||
name in the I<caller's> namespace. Calling this subroutine is equivalent to
|
||||
calling C<< <class>->throw(@_) >> for the given exception class.
|
||||
|
||||
Besides convenience, using aliases also allows for additional compile time
|
||||
checking. If the alias is called I<without parentheses>, as in C<throw_fields
|
||||
"an error occurred">, then Perl checks for the existence of the
|
||||
C<throw_fields> subroutine at compile time. If instead you do C<<
|
||||
ExceptionWithFields->throw(...) >>, then Perl checks the class name at
|
||||
runtime, meaning that typos may sneak through.
|
||||
|
||||
=item * description
|
||||
|
||||
Each exception class has a description method that returns a fixed
|
||||
string. This should describe the exception I<class> (as opposed to any
|
||||
particular exception object). This may be useful for debugging if you start
|
||||
catching exceptions you weren't expecting (particularly if someone forgot to
|
||||
document them) and you don't understand the error messages.
|
||||
|
||||
=back
|
||||
|
||||
The C<Exception::Class> magic attempts to detect circular class hierarchies
|
||||
and will die if it finds one. It also detects missing links in a chain, for
|
||||
example if you declare Bar to be a subclass of Foo and never declare Foo.
|
||||
|
||||
=head1 L<Try::Tiny>
|
||||
|
||||
If you are interested in adding try/catch/finally syntactic sugar to your code
|
||||
then I recommend you check out L<Try::Tiny>. This is a great module that helps
|
||||
you ignore some of the weirdness with C<eval> and C<$@>. Here's an example of
|
||||
how the two modules work together:
|
||||
|
||||
use Exception::Class ( 'My::Exception' );
|
||||
use Scalar::Util qw( blessed );
|
||||
use Try::Tiny;
|
||||
|
||||
try {
|
||||
might_throw();
|
||||
}
|
||||
catch {
|
||||
if ( blessed $_ && $_->isa('My::Exception') ) {
|
||||
handle_it();
|
||||
}
|
||||
else {
|
||||
die $_;
|
||||
}
|
||||
};
|
||||
|
||||
Note that you B<cannot> use C<< Exception::Class->caught >> with L<Try::Tiny>.
|
||||
|
||||
=head1 Catching Exceptions Without L<Try::Tiny>
|
||||
|
||||
C<Exception::Class> provides some syntactic sugar for catching exceptions in a
|
||||
safe manner:
|
||||
|
||||
eval {...};
|
||||
|
||||
if ( my $e = Exception::Class->caught('My::Error') ) {
|
||||
cleanup();
|
||||
do_something_with_exception($e);
|
||||
}
|
||||
|
||||
The C<caught> method takes a class name and returns an exception object if the
|
||||
last thrown exception is of the given class, or a subclass of that class. If
|
||||
it is not given any arguments, it simply returns C<$@>.
|
||||
|
||||
You should B<always> make a copy of the exception object, rather than using
|
||||
C<$@> directly. This is necessary because if your C<cleanup> function uses
|
||||
C<eval>, or calls something which uses it, then C<$@> is overwritten. Copying
|
||||
the exception preserves it for the call to C<do_something_with_exception>.
|
||||
|
||||
Exception objects also provide a caught method so you can write:
|
||||
|
||||
if ( my $e = My::Error->caught ) {
|
||||
cleanup();
|
||||
do_something_with_exception($e);
|
||||
}
|
||||
|
||||
=head2 Uncatchable Exceptions
|
||||
|
||||
Internally, the C<caught> method will call C<isa> on the exception object. You
|
||||
could make an exception "uncatchable" by overriding C<isa> in that class like
|
||||
this:
|
||||
|
||||
package Exception::Uncatchable;
|
||||
|
||||
sub isa { shift->rethrow }
|
||||
|
||||
Of course, this only works if you always call C<< Exception::Class->caught >>
|
||||
after an C<eval>.
|
||||
|
||||
=head1 USAGE RECOMMENDATION
|
||||
|
||||
If you're creating a complex system that throws lots of different types of
|
||||
exceptions, consider putting all the exception declarations in one place. For
|
||||
an app called Foo you might make a C<Foo::Exceptions> module and use that in
|
||||
all your code. This module could just contain the code to make
|
||||
C<Exception::Class> do its automagic class creation. Doing this allows you to
|
||||
more easily see what exceptions you have, and makes it easier to keep track of
|
||||
them.
|
||||
|
||||
This might look something like this:
|
||||
|
||||
package Foo::Bar::Exceptions;
|
||||
|
||||
use Exception::Class (
|
||||
Foo::Bar::Exception::Senses =>
|
||||
{ description => 'sense-related exception' },
|
||||
|
||||
Foo::Bar::Exception::Smell => {
|
||||
isa => 'Foo::Bar::Exception::Senses',
|
||||
fields => 'odor',
|
||||
description => 'stinky!'
|
||||
},
|
||||
|
||||
Foo::Bar::Exception::Taste => {
|
||||
isa => 'Foo::Bar::Exception::Senses',
|
||||
fields => [ 'taste', 'bitterness' ],
|
||||
description => 'like, gag me with a spoon!'
|
||||
},
|
||||
|
||||
...
|
||||
);
|
||||
|
||||
You may want to create a real module to subclass L<Exception::Class::Base> as
|
||||
well, particularly if you want your exceptions to have more methods.
|
||||
|
||||
=head2 Subclassing Exception::Class::Base
|
||||
|
||||
As part of your usage of C<Exception::Class>, you may want to create your own
|
||||
base exception class which subclasses L<Exception::Class::Base>. You should
|
||||
feel free to subclass any of the methods documented above. For example, you
|
||||
may want to subclass C<new> to add additional information to your exception
|
||||
objects.
|
||||
|
||||
=head1 Exception::Class FUNCTIONS
|
||||
|
||||
The C<Exception::Class> method offers one function, C<Classes>, which is not
|
||||
exported. This method returns a list of the classes that have been created by
|
||||
calling the C<Exception::Class> C<import> method. Note that this is I<all>
|
||||
the subclasses that have been created, so it may include subclasses created by
|
||||
things like CPAN modules, etc. Also note that if you simply define a subclass
|
||||
via the normal Perl method of setting C<@ISA> or C<use base>, then your
|
||||
subclass will not be included.
|
||||
|
||||
=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 DONATIONS
|
||||
|
||||
If you'd like to thank me for the work I've done on this module, please
|
||||
consider making a "donation" to me via PayPal. I spend a lot of free time
|
||||
creating free software, and would appreciate any support you'd care to offer.
|
||||
|
||||
Please note that B<I am not suggesting that you must do this> in order for me
|
||||
to continue working on this particular software. I will continue to do so,
|
||||
inasmuch as I have in the past, for as long as it interests me.
|
||||
|
||||
Similarly, a donation made in this way will probably not make me work on this
|
||||
software much more, unless I get so many donations that I can consider working
|
||||
on free software full time (let's all have a chuckle at that together).
|
||||
|
||||
To donate, log into PayPal and send money to autarch@urth.org, or use the
|
||||
button at L<http://www.urth.org/~autarch/fs-donation.html>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
=for stopwords Alexander Batyrshin Leon Timmermans Ricardo Signes
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Alexander Batyrshin <0x62ash@gmail.com>
|
||||
|
||||
=item *
|
||||
|
||||
Leon Timmermans <fawaka@gmail.com>
|
||||
|
||||
=item *
|
||||
|
||||
Ricardo Signes <rjbs@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=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
|
||||
595
database/perl/vendor/lib/Exception/Class/Base.pm
vendored
Normal file
595
database/perl/vendor/lib/Exception/Class/Base.pm
vendored
Normal file
@@ -0,0 +1,595 @@
|
||||
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
|
||||
Reference in New Issue
Block a user