package Error::Hierarchy::Util;
use strict;
use warnings;
use Data::Miscellany 'is_defined';
use Error::Hierarchy::Mixin;    # to get UNIVERSAL::throw()
our $VERSION = '0.09';
use base 'Exporter';
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 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);
}

# 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 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]")
}

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__



=head1 NAME

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

=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

=over 4

=item C<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.

=item C<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.

=item C<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.

=item C<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.

=item C<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.

=item C<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.

=item C<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.

=item C<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.

=item C<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>.

=item C<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>.

=item C<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.

=item C<loader_callback($coderef)>

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

=item C<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.

=back

=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>.

=head1 INSTALLATION

See perlmodinstall for information and options on installing Perl modules.

=head1 AVAILABILITY

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

=head1 AUTHORS

Marcel GrE<uuml>nauer, C<< <marcel@cpan.org> >>

=head1 COPYRIGHT AND LICENSE

Copyright 2004-2009 by the authors.

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


=cut

