Error::Hierarchy::Util - Assertions and other tools

  use Error::Hierarchy::Util qw/assert_defined assert_is_integer/;

  sub foo {
    my ($self, $bar, $baz) = @_;
    assert_defined $bar, 'called without defined bar';
    assert_is_integer $baz;
    # ...
  }

    assert_arrayref $r, '$r is not an array reference';

    assert_nonempty_arrayref $r, '$r does not have any elements';

    assert_hashref $r, '$r is not a hash reference';

    assert_nonempty_hashref $r, '$r does not have any key/value pairs';

    assert_class $obj, 'Some::Class';

    sub foo {
        my ($self, $bar) = @_;
        assert_defined $bar, 'called without bar';
        ...
    }

    sub get_foo {
        my $self = shift;
        assert_read_only(@_);
        $self->{foo};
    }

    sub set_log_level {
        my ($self, $log_level) = @_;
        assert_is_integer($log_level);
        ...
    }

    sub my_method {
        my ($self, %args) = @_;
        assert_named_args(\%args, qw(foo +bar baz));
        # ...
    }

    load_class 'Some::Class', 1;

use 5.008;
use strict;
use warnings;

package Error::Hierarchy::Util;
BEGIN {
  $Error::Hierarchy::Util::VERSION = '1.103530';
}
# ABSTRACT: Assertions and other tools
use Data::Miscellany 'is_defined';
use Error::Hierarchy::Mixin;    # to get UNIVERSAL::throw()
use Exporter qw(import);
our %EXPORT_TAGS = (
    ref => [
        qw{
          assert_arrayref assert_nonempty_arrayref
          assert_hashref  assert_nonempty_hashref
          }
    ],
    misc => [
        qw{
          assert_class assert_defined assert_read_only assert_is_integer
          assert_getopt assert_enum assert_named_args load_class
          }
    ],
);
our @EXPORT_OK = @{ $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ] };

sub assert_class ($$) {
    my ($obj, $class) = @_;
    return if ref $obj && $obj->isa($class);
    local $Error::Depth = $Error::Depth + 2;
    throw Error::Hierarchy::Internal::Class(
        class_expected => $class,
        class_got      => ref($obj),
    );
}

sub assert_read_only {
    return unless @_;
    local $Error::Depth = $Error::Depth + 2;
    my $sub = (caller(1))[3];
    throw Error::Hierarchy::Internal::ReadOnlyAttribute(attribute => $sub,);
}

# In assert_condition we use
#
#   local $Error::Depth = $Error::Depth + 3;
#
# because:
#
# +1 to make assert_condition invisible to caller
#
# +1 to make assert_defined and friends invisible to caller
#
# +1 to make the one who called assert_* invisible to caller, since we
# want to report the location where the method that checks its args using
# assert_* was called from.
sub assert_condition ($$$) {
    my ($condition, $exception_class, $custom_message) = @_;
    return if $condition;

    # get the name of the first sub an assert_* sub was called with the unmet
    # assertion
    my ($level, $sub);
    do {
        $sub = (caller(++$level))[3];
    } until $sub !~ /^.*::assert_/;

    # XXX: shouldn't we use $level here instead of 3?
    local $Error::Depth = $Error::Depth + 3;
    $exception_class->throw(custom_message => "[$sub] $custom_message");
}

sub assert_defined ($$) {
    my ($val, $custom_message) = @_;

    # If it's a value object, it might have been autogenerated; see
    # value_object accessor generator, in which case it might not have a value
    # yet, but $val would be defined - it's the empty value object.
    # Performance optimization: Because this function is called so often, we
    # don't call assert_condition() unless it is necessary.
    return if is_defined($val);
    assert_condition(0, 'Error::Hierarchy::Internal::ValueUndefined',
        $custom_message);
}

sub assert_arrayref ($$) {
    my ($val, $custom_message) = @_;
    assert_condition(
        (defined($val) && ref($val) eq 'ARRAY'),
        'Error::Hierarchy::Internal::NoArrayRef',
        $custom_message
    );
}

sub assert_nonempty_arrayref ($$) {
    my ($val, $custom_message) = @_;
    assert_condition(
        (defined($val) && ref($val) eq 'ARRAY' && scalar @$val),
        'Error::Hierarchy::Internal::EmptyArrayRef',
        $custom_message
    );
}

sub assert_hashref ($$) {
    my ($val, $custom_message) = @_;
    assert_condition(
        (defined($val) && ref($val) eq 'HASH'),
        'Error::Hierarchy::Internal::NoHashRef',
        $custom_message
    );
}

sub assert_nonempty_hashref ($$) {
    my ($val, $custom_message) = @_;
    assert_condition(
        (defined($val) && ref($val) eq 'HASH' && scalar keys %$val),
        'Error::Hierarchy::Internal::EmptyHashRef',
        $custom_message
    );
}

sub assert_is_integer ($) {
    my $val = shift;
    assert_condition(
        ($val =~ /^[1-9]$/),
        'Error::Hierarchy::Internal::CustomMessage',
        'expected an integer value from 1 to 9'
    );
}

# In Data::Conveyor, this function is called by service methods to verify
# options passed to it. If the value given is true, we just return. If it is
# false, we throw a special "help exception". When the shell service interface
# calls a service method, it catches this help exception and prints
# manpage-like help information for that method.
sub assert_getopt ($$) {
    my ($val, $custom_message) = @_;
    return if $val;
    Data::Conveyor::Exception::ServiceMethodHelp->throw(
        custom_message => $custom_message);
}

sub assert_named_args {
    my ($args, @args_spec) = @_;
    my (%supported_args, @required_args);
    for (@args_spec) {
        /(^\+)?(.*)/;
        my $required = defined $1 && $1 eq '+';
        $supported_args{$2}++;
        push @required_args => $2 if $required;
    }
    my @unsupported_args = grep { !$supported_args{$_} } keys %$args;
    my @missing_required_args = grep { !defined $args->{$_} } @required_args;
    return if @unsupported_args == 0 && @missing_required_args == 0;
    my $sub = (caller(1))[3];
    my $message = "$sub() called with illegal named arguments:\n";
    if (@missing_required_args) {
        local $" = ', ';
        $message .= "    missing required arguments: @missing_required_args\n";
    }
    if (@unsupported_args) {
        local $" = ', ';
        $message .= "    unsupported arguments: @unsupported_args\n";
    }
    Error::Hierarchy::Internal::CustomMessage->throw(custom_message => $message);
}

sub assert_enum {
    my ($val, $enum_arrayref, $custom_message) = @_;
    for my $valid_value (@$enum_arrayref) {
        return if $val eq $valid_value;
    }
    throw Error::Hierarchy::Internal::CustomMessage(
        custom_message => "$custom_message: invalid value [$val]");
}

# support for "virtual" classes that do not exist as files.
# this is of no use for payload reinstantiation in a new
# process, as Storable calls require() before touching any
# accessor. it does allow a few things, though:
# load_class XYZ, 1 for example, or calling static methods
# directly, such as XYZ->DEFAULTS.
sub loader_callback {
    shift if $_[0] eq __PACKAGE__;
    our $loader_callback;
    if (my $callback = shift) {
        throw Error::Hierarchy::Internal::CustomMessage(
            custom_message => "argument must be a coderef")
          unless ref $callback eq 'CODE';
        $loader_callback = $callback;
    }
    $loader_callback;
}

sub load_class ($$) {
    my ($class, $verbose) = @_;
    assert_defined $class, 'called without class argument.';

    # An attempt at optimization: This sub is called very often. By relying on
    # every class defining a $VERSION, we can shortcut costly processing.
    {
        no strict 'refs';
        return if ${"$class\::VERSION"};
    }

    # report errors from perspective of caller
    local $Error::Depth = $Error::Depth + 1;
    eval "require $class";
    if (defined($@) && $@ ne '') {

        # allow for dynamic class generation
        if (my $code = __PACKAGE__->loader_callback) {
            return $class if $code->($class);
        }

        # this error is so severe we want to print it during test mode
        print $@ if $verbose;
        throw Error::Hierarchy::Internal::CustomMessage(custom_message =>
              sprintf("Couldn't load package [%s]: %s", $class, $@),);
    }
    $class;
}
1;


__END__