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__
=pod

=head1 NAME

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

=head1 VERSION

version 1.103530

=head1 SYNOPSIS

  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;
    # ...
  }

=head1 DESCRIPTION

This module provides some functions that can make assertions about a given
value and, if necessary, throw an appropriate exception. It also provides
other tools.

None of the functions are exported by default, but they can be imported using
the standard L<Exporter> semantics.

=head1 FUNCTIONS

=head2 assert_arrayref($value, $error_message)

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

Takes as arguments a value and a custom message. If the value is not an array
reference, it throws a L<Error::Hierarchy::Internal::NoArrayRef> exception
with the given custom message.

=head2 assert_nonempty_arrayref($value, $error_message)

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

Takes as arguments a value and a custom message. If the value is not a
reference to an array with at least one element, it throws a
L<Error::Hierarchy::Internal::EmptyArrayRef> exception with the given custom
message.

=head2 assert_hashref($value, $error_message)

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

Takes as arguments a value and a custom message. If the value is not a hash
reference, it throws a L<Error::Hierarchy::Internal::NoHashRef> exception with
the given custom message.

=head2 assert_nonempty_hashref($value, $error_message)

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

Takes as arguments a value and a custom message. If the value is not a
reference to a hash with at least one key/value pair, it throws a
L<Error::Hierarchy::Internal::EmptyHashRef> exception with the given custom
message.

=head2 assert_class($object, $class_name)

    assert_class $obj, 'Some::Class';

Takes as arguments an object and a class name. If the object is not of the
given class type, it throws a L<Error::Hierarchy::Internal::Class> exception.

=head2 assert_defined($expression, $error_message)

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

Takes as arguments a value and a custom message. If the value is not defined,
it throws a L<Error::Hierarchy::Internal::ValueUndefined> exception with
the given custom message.

=head2 assert_read_only(@args)

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

Checks whether the calling subroutine was called with any arguments. If so, it
throws a L<Error::Hierarchy::Internal::ReadOnlyAttribute> exception.

=head2 assert_is_integer($value)

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

Takes a value and unless it is an integer between 1 and 9, it throws a
L<Error::Hierarchy::Internal::CustomMessage> exception with a predefined
message.

The limitation of the value makes this probably a function that's not
very useful. I should make this more generic.

=head2 assert_condition($value, $exception_class, $error_message))

This function is used internally by many other C<assert_*()> functions.

Checks whether the condition indicated by the value is true. If so, it just
returns. If the condition is false, an exception of the indicated class is
thrown, with the given message. The call stack is checked to find the first
caller whose name does not begin with C<assert_>. That caller's name is
prepended to the custom message.

The exception class indicated by C<$exception_class> is supposed to be a
marker subclass of L<Error::Hierarchy::Internal::CustomMessage>.

=head2 assert_getopt()

Provides integration for C<Data::Conveyor>. In command-line applications, this
function can be called 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".

This should be moved to C<Data::Conveyor>.

=head2 assert_named_args(\%args, @args_spec)

This function helps in validating named arguments passed to a method or
function. The first argument is a reference to the hash of named arguments,
the remaining arguments define which argument names are allowed. If an
argument name starts with a C<+> sign, it means that this argument is
mandatory.

For example, assume your method only accepts the keys C<foo>, C<bar> and
C<baz>, and C<bar> is mandatory. Usually you will write your method like this:

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

If there was a validation error, an exception of type
L<Error::Hierarchy::Internal::CustomMessage> will be thrown with details about
what went wrong.

=head2 assert_enum()

Takes a value and a reference to an array of valid values - that is, the
enumeration. If the value is not among the enumerated valid values, an
exception is thrown.

=head2 loader_callback($coderef)

Support for "virtual" classes that do not exist as files. It is used in
C<load_class()>, so see its documentation.

=head2 load_class($class, $verbose))

    load_class 'Some::Class', 1;

Takes as arguments a package name and a boolean verbosity flag. Tries to load
the package and if it can't be loaded, it throws a
L<Error::Hierarchy::Internal::CustomMessage> exception with the error message
obtained when trying to load the package.

To save time, this function checks whether the package defines a C<$VERSION>
and if so, it assumes that the package has already been loaded and returns
right away.

If the class can't be loaded via C<require()> but we have a
C<loader_callback()>, it is invoked with the class name.

If the verbose flag is set, the error code - C<$@> - is printed immediately if
a problem occurs. You might want to set this flag in when testing your code to
get a quick feedback on loading problems, but you should have a graceful
method to deal with the problem anyway.

This function is called C<load_class()> and not C<load_package()> for
historical reasons.

=head1 INSTALLATION

See perlmodinstall for information and options on installing Perl modules.

=head1 BUGS AND LIMITATIONS

No bugs have been reported.

Please report any bugs or feature requests through the web interface at
L<http://rt.cpan.org/Public/Dist/Display.html?Name=Error-Hierarchy>.

=head1 AVAILABILITY

The latest version of this module is available from the Comprehensive Perl
Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN
site near you, or see L<http://search.cpan.org/dist/Error-Hierarchy/>.

The development version lives at L<http://github.com/hanekomu/Error-Hierarchy>
and may be cloned from L<git://github.com/hanekomu/Error-Hierarchy>.
Instead of sending patches, please fork this project using the standard
git and github infrastructure.

=head1 AUTHOR

Marcel Gruenauer <marcel@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2004 by Marcel Gruenauer.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut