package Unexpected::TraitFor::ExceptionClasses; use namespace::autoclean; use Unexpected::Functions qw( inflate_message ); use Moo::Role; my $ROOT = 'Unexpected'; my $Classes = { $ROOT => {} }; __PACKAGE__->add_exception( 'Unspecified' => { parents => $ROOT, error => 'Parameter [_1] not specified' } ); # Public attributes has 'class' => is => 'ro', isa => sub { ($_[ 0 ] and exists $Classes->{ $_[ 0 ] }) or die inflate_message ( 'Exception class [_1] does not exist', $_[ 0 ] ) }, default => $ROOT; # Construction around 'BUILDARGS' => sub { my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args ); if (exists $attr->{class} and my $class = $attr->{class}) { ref $class eq 'CODE' and $class = $attr->{class} = $class->(); defined $class and exists $Classes->{ $class } and $attr->{error} //= $Classes->{ $class }->{error}; } return $attr; }; # Public class methods sub add_exception { my ($self, $class, $args) = @_; $args //= {}; defined $class or die "Parameter 'exception class' not specified"; exists $Classes->{ $class } and die "Exception class ${class} already exists"; ref $args ne 'HASH' and $args = { parents => $args }; my $parents = $args->{parents} //= [ $ROOT ]; ref $parents ne 'ARRAY' and $parents = $args->{parents} = [ $parents ]; for my $parent (@{ $parents }) { exists $Classes->{ $parent } or die "Exception class ${class} parent class ${parent} does not exist"; } $Classes->{ $class } = $args; return; } sub is_exception { return $_[ 1 ] && !ref $_[ 1 ] && exists $Classes->{ $_[ 1 ] } ? 1 : 0; } # Public object methods sub instance_of { my ($self, $wanted) = @_; $wanted or return 0; exists $Classes->{ $wanted } or die "Exception class ${wanted} does not exist"; my @classes = ( $self->class ); while (defined (my $class = shift @classes)) { $class eq $wanted and return 1; exists $Classes->{ $class }->{parents} and push @classes, @{ $Classes->{ $class }->{parents} }; } return 0; } 1; __END__ =pod =encoding utf8 =head1 Name Unexpected::TraitFor::ExceptionClasses - Define an exception class hierarchy =head1 Synopsis package YourExceptionClass; use Moo; extends 'Unexpected'; with 'Unexpected::ExceptionClasses'; __PACKAGE__->add_exception( 'A' ); __PACKAGE__->add_exception( 'B', { parents => 'A' } ); __PACKAGE__->add_exception( 'C', 'A' ); # same but shorter __PACKAGE__->add_exception( 'D', [ 'B', 'C' ] ); # diamond pattern # Then elsewhere __PACKAGE__->throw( 'error message', { class => 'C' } ); # Elsewhere still my $e = __PACKAGE__->caught; $e->class eq 'C'; # true $e->instance_of( 'A' ); # true $e->instance_of( 'B' ); # false $e->instance_of( 'C' ); # true $e->instance_of( 'D' ); # false =head1 Description Allows for the creation of an exception class hierarchy. Exception classes inherit from one or more existing classes, ultimately all classes inherit from the C<Unexpected> exception class =head1 Configuration and Environment Defines the following attributes; =over 3 =item C<class> Defaults to C<Unexpected>. Can be used to differentiate different classes of error. Non default values for this attribute must have been defined with a call to L</add_exception> otherwise an exception will be thrown. Oh the irony =back Defines the C<Unspecified> exception class with a default error message. Once the exception class is defined the the following; use Unexpected::Functions qw( Unspecified ); will import a subroutine that when called returns it's own name. This is a suitable value for the C<class> attribute YourExceptionClass->throw( class => Unspecified, args => [ 'param name' ] ); =head1 Subroutines/Methods =head2 BUILDARGS Applies the default error message if one exists and the attributes for the soon to be constructed exception lacks one =head2 add_exception YourExceptionClass->add_exception( 'new_classname', [ 'parent1', 'parent2']); Defines a new exception class. Parent classes must already exist. Default parent class is C<Unexpected>; $class->add_exception( 'new_classname' => { parents => [ 'parent1' ], error => 'Default error message [_1]' } ); Sets the default error message for the exception class When defining your own exception class import and call L<has_exception|File::DataClass::Functions/has_exception> which will call this class method. The functions subroutine signature is like that of C<has> in C<Moo> =head2 instance_of $bool = $exception_obj->instance_of( 'exception_classname' ); Is the exception object an instance of the exception class =head2 is_exception $bool = YourExceptionClass->is_exception( 'exception_classname' ); Returns true if the exception class exits as a result of a call to L</add_exception> =head1 Diagnostics None =head1 Dependencies =over 3 =item L<Moo::Role> =back =head1 Incompatibilities There are no known incompatibilities in this module =head1 Bugs and Limitations There are no known bugs in this module. Please report problems to http://rt.cpan.org/NoAuth/Bugs.html?Dist=Unexpected. Patches are welcome =head1 Acknowledgements Larry Wall - For the Perl programming language =head1 Author Peter Flanigan, C<< <pjfl@cpan.org> >> =head1 License and Copyright Copyright (c) 2015 Peter Flanigan. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<perlartistic> This program is distributed in the hope that it will be useful, but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE =cut # Local Variables: # mode: perl # tab-width: 3 # End: