File Coverage

blib/lib/Err.pm

Criterion	Covered	Total	%
statement	50	55	90.9
branch	17	20	85.0
condition			n/a
subroutine	13	14	92.8
pod	4	4	100.0
total	84	93	90.3

package Err;
use base qw(Exporter);

use strict;
use warnings;

use Carp qw(croak);
use Scalar::Util qw(blessed);

# load Exception::Class and declare the Err::Exception baseclass
use Exception::Class ("Err::Exception");

our $VERSION = "0.02";
our @EXPORT_OK;

my %defaults;  # default arguments

########################################################################

sub _class_from_code {
    my $code = shift;
    return "Exception::Class::Base" unless length $code;
    return "Err::Exception" if $code eq ".";
    $code =~ s/\A\./Err::Exception::/x;
    $code =~ s/[.']/::/gx;
    return $code;
}

########################################################################

sub is_err($) {
    return unless blessed $_;
    return $_->isa(_class_from_code(shift));
}
push @EXPORT_OK, "is_err";

sub ex_is_err($) {
    return unless blessed $@;
    return $@->isa(_class_from_code(shift));
}
push @EXPORT_OK, "ex_is_err";

########################################################################

sub throw_err($$@) {  ## no critic (RequireFinalReturn)
    my $err_class = _class_from_code(shift);
    my $message = shift;

    # pre-populate our arguments from the defaults
    my %args = (%{ $defaults{ $err_class } || {} }, @_);

    # throw the exception
    $err_class->throw( message => $message, %args );
}
push @EXPORT_OK, "throw_err";

########################################################################

sub declare_err($%) {
    my $err_class = _class_from_code(shift);
    my %args = @_;

    # set the parent
    my $parent;
    $parent = _class_from_code(delete $args{isa}) if defined $args{isa};
    unless (defined $parent) {
        $parent = $err_class;

        # attempt to strip off the last ::whatever, but if we can't
        # (presumably because the class name only had one part) just
        # default to Err::Exception
        unless($parent =~ s/::[^:]+\z//x) {
            $parent = "Err::Exception";
        }
    }

    # set the description
    my $description = delete $args{description};

    # everything else is fields.  Remember them.
    $defaults{ $err_class } = \%args;

    # declare the exception with Exception::Class
    Exception::Class->import(
      $err_class => {
        isa => $parent,
        (defined $description ? (description => $description) : ()),
        fields => [keys %{ $defaults{ $err_class } }],
      }
    );

    return;
}
push @EXPORT_OK, "declare_err";

########################################################################
# code below here is to support compile time checking (technically
# "CHECK" time checking) that exceptions have been properly declared when
# they're referenced in is_err and throw_err.
#
# None of it will be checked if B::CallChecker is not installed (but the
# code will still function okay)
########################################################################

if (eval "use B::CallChecker; 1") {

   ########################################################################
   # routine to work out if a code has previously been declared or not
   ########################################################################

    my %classes_we_have_declared;

    sub _is_code_declared {
        my $err_class = _class_from_code(shift);

        # has this been declared with a declare_err call?
        return 1 if $classes_we_have_declared{ $err_class };

        # no? well, there's still a chance that someone has
        # declared it manually! We should check isa (note, we can't
        # *just* check isa because it's entirely possible that someone
        # has correctly used a declare_err to declare this code
        # but that declare_err statement hasn't been executed yet
        # (because code_is_declared is being called at CHECK time)
        # in which case the code will have been registered but the
        # @ISA will not have been setup at that point)
        return $err_class->isa("Exception::Class::Base");
    }

    ########################################################################
    # wrapping throw_err, is_err, ex_is_err
    ########################################################################

    foreach my $subname (qw(throw_err is_err ex_is_err)) {
        my $uboat = do {
            no strict 'refs';
            \&{ $subname };
        };

        # remember what the normal checking routine would do
        my ($original_check, $data) = B::CallChecker::cv_get_call_checker($uboat);

        # install our own checker that doesn't actually do prototype
        # checking but instead interrogates the first argument to see
        # if it's a valid exception code
        B::CallChecker::cv_set_call_checker($uboat, sub {

            # extract the first argument
            my $const = $_[0]->first->first->sibling;

            # ignore it if it's not a constant.  We can't check this
            # at compile time, so skip the check
            unless ($const->name eq "const") {
                croak "Improper use of $subname.  The first argument to $subname was not a constant string";
            }

            # get the value of the constant
            my $code = ${ $const->sv->object_2svref };

            # throw a compile time error if the code
            # hasn't been declared yet at compile time
            unless (_is_code_declared($code)) {
                croak "Undeclared exception code $code used in $subname (you must declare exception classes before referencing them)";
            }

            # return the results of making the normal check
            return $original_check->(@_);
        },$data);
    }

    ########################################################################
    # declare_err wrapping
    ########################################################################

    my $uboat = \&declare_err;

    # remember what the normal checking routine would do
    my ($original_check, $data) = B::CallChecker::cv_get_call_checker($uboat);

    # install our own checker that doesn't actually do prototype
    # checking but instead interrogates the first argument to
    # get the check
    B::CallChecker::cv_set_call_checker($uboat, sub {

        # extract the first argument
        my $const = $_[0]->first->first->sibling;

        # ignore it if it's not a constant.  We can't check this
        # at compile time, so skip the check
        unless ($const->name eq "const") {
            croak "Improper use of declare_err.  The first argument to declare_err was not a constant string";
        }

        # get the value of the constant
        my $code = ${ $const->sv->object_2svref };
        $classes_we_have_declared{ _class_from_code($code) } = 1;

        # return the results of making the normal check
        return $original_check->(@_);
    },$data);
}

########################################################################

1;

__END__