570 lines
17 KiB
Perl
570 lines
17 KiB
Perl
|
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
|