Bivio::Test
# Copyright (c) 2001-2007 bivio Software, Inc. All Rights reserved.
# $Id$
package Bivio::Test;
use strict;
use Bivio::Base 'Collection.Attributes';
b_use('Bivio::IO::Trace');
# C<Bivio::Test> supports declarative unit testing. A declarative test allows
# you to define what you want to test very succinctly. Here's an example:
#
# #!perl -w
# use strict;
# use Bivio::TypeError;
# use Bivio::Test;
# Bivio::Test->new('Bivio::Type::Integer')->unit([
# Bivio::Type::Integer => [
# from_literal => [
# ['1'] => [1],
# ['x'] => [undef, Bivio::TypeError->INTEGER],
# ],
# from_literal_or_die => [
# ['99'] => '99',
# ['x99'] => Bivio::DieCode->DIE,
# ],
# ],
# ]);
#
# The first argument to L<unit|"unit"> is a list of object groups. An object
# group is tuple of the object (class or instance) and a list of method groups.
# A method group is a tuple of the method name followed by a list of test cases.
# Each test case is a tuple of I<params> and an I<expect> value.
#
# If the return value is undef, specify C<[undef]> as the result. That's what
# the method should return if it doesn't return anything. perl methods return
# C<undef> implicitly if the last statement they execute is C<return;>. We
# recommend you always end your methods in a C<return> statement to avoid
# unexpected return values being used unexpectedly. perl by default returns the
# value of the last statement executed. This can have serious side-effects
# unless one is careful.
#
# To ignore the return result, specify C<undef> (as a scalar, not wrapped in an
# array_ref), i.e. the test case tuple should only include the parameter(s).
# Here's an example:
#
# do_something => [
# [1, 2, 3] => undef,
# ],
#
# The result of the call to the method C<do_something> will not be checked. If
# the method dies (throws an exception), the case will fail. When there is no
# exception, the case passes.
#
# If the I<expect> is an array_ref, it will be compared with the I<return>. If
# the method returns an array_ref, you'll need to wrap it one more time in an
# array_ref, e.g.
#
# make_array_ref => [
# [1, 2, 3] => [[1, 2, 3]],
# ]
#
# If I<expect> is a regexp_ref, the I<entire> I<return> will be compared
# to I<expect>. I<return> will be stringified with
# L<Bivio::IO::Ref::to_string|Bivio::IO::Ref/"to_string">.
#
# Here C<make_array_ref> is the routine being tested. It returns an array_ref of
# its arguments. We have an extra level of square brackets on the result
# of C<make_array_ref>.
#
# If the I<expect> is a code_ref, this will be a custom check_return (see
# L<check_return|"check_return"> and below) for this case only. If an exception
# is I<not> thrown, I<check_return> is called. If it is thrown, I<check_return>
# is not called.
#
# If the I<expect> is a L<Bivio::DieCode|Bivio::DieCode>, an exception is
# expected to be thrown and must match the L<Bivio::DieCode|Bivio::DieCode>
# exactly.
#
#
# Sometimes it is difficult to specify a return result. For example, in
# L<Bivio::SQL::Connection|Bivio::SQL::Connection>, the result is often a
# C<DBI::st>. The result can't be compared structurally.
#
# You can specify a I<check_return> or I<compute_return> option to L<new|"new">
# or at the object or method level. You can also specify a I<class_name> to
# require. When I<class_name> implements C<new>, it will be called with the
# I<object> params. Here's an example with global I<check_return> and the
# implicit call to I<new>:
#
# Bivio::Test->new->({
# class_name => 'Bivio::Math::EMA',
# check_return => sub {
# my($case, $actual, $expect) = @_;
# # Round to 6 decimal places
# $case->actual_return(
# [POSIX::floor($actual->[0] * 1000000 + 0.5) / 1000000]);
# return $expect;
# },
# })->unit([
# 30 => [
# compute => [
# 1 => 1,
# 2 => 1.666666,
# 2 => 1.888888,
# ],
# ],
# ]);
#
# In this case, we could also have specified the option at the object level
# as in:
#
# Bivio::Test->unit([
# {
# class_name => 'Bivio::Math::EMA',
# object => 30,
# check_return => sub {
# my($case, $actual, $expect) = @_;
# $case->actual_return(
# [POSIX::floor($actual->[0] * 1000000 + 0.5) / 1000000];
# return $expect;
# },
# } => [
# compute => [
# [1] => [1],
# [2] => [1.666666],
# [2] => [1.888888],
# ],
# ],
# ]);
#
# Note the introduction of a hash_ref in place of the object C<30> and the
# introduction of the named attributes: C<object> and C<check_return>.
#
# The object level overrides the value supplied to L<new|"new">.
# The method level overrides the object level.
#
# The following options are allowed:
#
#
# check_die_code : code_ref
#
# See L<check_die_code|"check_die_code">.
#
# check_return : code_ref
#
# See L<check_return|"check_return">.
#
# class_name : string
#
# Name of class to test. Will be loaded dynamically with
# L<Bivio::IO::ClassLoader|Bivio::IO::ClassLoader>.
# L<create_object|"create_object"> will be set to
# L<default_create_object|"default_create_object">
# unless already set.
#
# compute_params : code_ref
#
# See L<compute_params|"compute_params">
#
# compute_return : code_ref
#
# See L<compute_return|"compute_return">.
#
# create_object : code_ref
#
# See L<create_object|"create_object">
#
# method : any (method attribute)
#
# Name of the method to call in the method group. The following
# two are equivalent:
#
# {
# method => 'my_method',
# } => [
# <cases>,
# ],
#
# and
#
# my_method => [
# <cases>,
# ],
#
# method_is_autoloaded : boolean [0]
#
# By default, an object must implement the methods in the test cases. For
# AUTOLOAD cases, set this option to true.
#
# object : any (object attribute)
#
# Used as the object, to create the object, or as params to
# L<default_create_object|"default_create_object">. The following
# two are equivalent:
#
# {
# object => <create arg>,
# } => [
# <method groups>,
# ],
#
# and
# <creation args> => [
# <method groups>,
# ],
#
# print : code_ref (global attribute)
#
# You can override the print function used to output the results of the test.
# This is probably useful for testing L<Bivio::Test|Bivio::Test> itself.
# Only acceptable as an attribute on the
# L<Bivio::Test|Bivio::Test> object itself.
#
# want_void : boolean [0]
#
# want_scalar : boolean [0]
#
# Caveat: we recommend executing all methods in a list
# context, and that methods should avoid being dependent on context.
# (For an example of how to avoid being context sensitive,
# see L<Bivio::Collection::Attributes::get|Bivio::Collection::Attributes/"get">).
#
# That being said, you sometimes need to test modules which are context
# sensitive, i.e. they return a scalar in a scalar context, an array in a list
# context. Set want_scalar or want_void to true if you want all methods in the
# case group to be invoked in a scalar or void context.
#
# You can also specify a L<imperative_case|"imperative_case"> at the method
# level, e.g.,
#
# Bivio::Test->new('Bivio::Math::EMA')->unit([
# 30 => sub {
# my($case, $object) = @_;
# foreach my $sub_case (
# [1 => 1],
# [2 => 1.666666],
# [2 => 1.888888],
# ) {
# my($value, $expect) = @$sub_case;
# return 0
# unless $expect
# == POSIX::floor(
# $object->compute($value) * 1000000 + 0.5) / 1000000;
# },
# return 1;
# },
# ]);
#
# You may also specify an I<imperative_case> as the I<method> option of a
# method group. This allows you to specify the return value.
#
#
# If a method takes no parameters and returns a simple scalar
# result, the case case be written, e.g.:
#
# Bivio::Test->unit([
# 'Bivio::Type::Integer' => [
# get_min => -999999999,
# get_max => 999999999,
# ],
# ]);
#
#
# After L<unit|"unit"> completes, the following attributes are set:
#
#
# failed : array_ref
#
# Numbers for the cases which I<failed>. Case numbers start at 1.
#
# passed : array_ref
#
# Numbers for the cases which I<passed>. Case numbers start at 1.
our($_CASE);
our($_SELF);
my($_IDI) = __PACKAGE__->instance_data_index;
our($_TRACE);
b_use('IO.Trace');
my(@_CALLBACKS) = qw(check_return check_die_code compute_params compute_return create_object);
my(@_PLAIN_OPTIONS) = qw(method_is_autoloaded class_name want_scalar want_void comparator);
my(@_ALL_OPTIONS) = (@_CALLBACKS, 'print', @_PLAIN_OPTIONS);
my(@_CASE_OPTIONS) = grep($_ ne 'print', @_ALL_OPTIONS);
my($_HANDLERS) = b_use('Biz.Registrar')->new;
my($_D) = b_use('Bivio.Die');
my($_CL) = b_use('IO.ClassLoader');
my($_U) = b_use('Bivio.UNIVERSAL');
my($_C) = b_use('Test.Case');
my($_DC) = b_use('Bivio.DieCode');
sub IGNORE_RETURN {
# B<EXPERIMENTAL>
#
# Return value to use when you want to ignore a return.
return @_ == 1 ? \&IGNORE_RETURN : 1;
}
sub current_case {
# Returns current case or dies.
return $_CASE || b_die('no current case');
}
sub current_self {
# Returns current running instance of this class or dies.
return $_SELF || b_die('no current self');
}
sub default_create_object {
my($case, $params) = @_;
# Implements L<create_object|"create_object"> interface. Calls
# L<new|"new"> on I<class_name> attribute.
#
# SPECIAL CASE: I<params> contains the a single value which is
# is name of the class, then the class name is returned and I<new>
# is not called. This allows mixing static (class) and instance tests.
my($c) = $case->get('class_name');
return @$params == 1 && $params->[0] eq $c ? $c : $c->new(@$params);
}
sub format_results {
my(undef, $num_ok, $max) = @_;
# Formats test results into a human readable string.
return $max == $num_ok
? "All ($max) tests PASSED\n"
: sprintf("FAILED %d (%.1f%%) and passed %d (%.1f%%)\n",
map {
$_, 100 * $_ / $max;
} ($max - $num_ok), $num_ok);
}
sub new {
my($proto, $options) = @_;
# Create a new test instance. You can specify options here or at
# the object or method levels of I<tests> as passed to L<unit|"unit">.
# See L<OPTIONS|"OPTIONS"> for more details.
my($self) = $proto->SUPER::new(_assert_options($options));
_load_class($self);
$self->[$_IDI] = {};
return $self;
}
sub register_handler {
shift;
$_HANDLERS->push_object(@_);
return;
}
sub unit {
my($self, $tests) = @_;
return ref($self) ? _eval($self, _compile($self, $tests))
: $self->new->unit($tests);
}
sub unsafe_current_self {
return $_SELF;
}
sub _add_option {
my($state, $in, $option) = @_;
# Sets $option in $state to value in $in. Returns false if
# $option not in $in.
return 0 unless exists($in->{$option});
$state->{$option} = $in->{$option};
delete($in->{$option});
return 1;
}
sub _assert_options {
my($options) = @_;
# Validates result_ok, compute_params, and printer options.
return {}
unless $options;
return {class_name => $options}
if !ref($options) && $options;
die('options not a hash_ref or class_name')
unless ref($options) eq 'HASH';
my($o) = {%$options};
foreach my $c (@_ALL_OPTIONS) {
next unless exists($o->{$c});
die($c, ': option not a subroutine (code_ref)')
unless ref($o->{$c}) eq 'CODE'
|| grep($c eq $_, @_PLAIN_OPTIONS);
delete($o->{$c});
}
_die('unknown option(s) passed to new: ', join(' ', sort(keys(%$o))))
if %$o;
return $options;
}
sub _catch {
return
unless my $die = $_D->catch_quietly(@_);
b_use('Agent.Task')->rollback(b_use('Agent.Request')->get_current)
if $_CL->was_required('Agent.Request')
&& $_CL->was_required('Agent.Task');
return $die;
}
sub _compile {
my($self, $objects) = @_;
# Compiles @$objects into a linear list of tuples.
my($state) = {
object_num => 0,
map(($_ => $self->unsafe_get($_)), @_CASE_OPTIONS),
};
_compile_assert_even($objects, $state);
my(@objects) = @$objects;
my($tests) = [];
while (@objects) {
_compile_object($self, $state, $tests, splice(@objects, 0, 2));
}
return $tests;
}
sub _compile_assert_array {
my($value, $state) = @_;
# Asserts value is an array_ref.
_compile_die($state, 'value must be an array_ref')
unless ref($value) eq 'ARRAY';
return;
}
sub _compile_assert_even {
my($value, $state) = @_;
# Asserts value is an even length array_ref.
_compile_assert_array($value, $state);
_compile_die($state, 'value has uneven elements in array')
unless int(@$value) % 2 == 0;
_compile_die($state, 'value has no elements in array')
unless int(@$value);
return;
}
sub _compile_case {
my($state, $tests, $params, $expect) = @_;
# Parses a single case and pushes it on @$tests.
$state->{case_num}++;
$params = [$params]
if defined($params) && !ref($params);
_compile_die($state, 'params must be array_ref, DieCode, or CODE')
unless ref($params) =~ /^(ARRAY|CODE)$/;
push(@$tests, my $case = $_C->new({
%$state,
params => $params,
}));
$case->expect($expect);
_trace($case) if $_TRACE;
return;
}
sub _compile_die {
my($state, @msg) = @_;
# Calls _die() with msg and state of compilation.
_die('Error compiling ', ref($state) eq 'HASH'
? $_C->new({%$state}) : $state, ': ', @msg);
# DOES NOT RETURN
}
sub _compile_method {
my($state, $tests, $method, $cases) = @_;
# Validates method and parses cases.
$state = _compile_options($state, 'method', $method);
$state->{comparator} ||= 'nested_differences';
$method = $state->{method};
if (ref($cases) eq 'ARRAY') {
_compile_assert_even($cases, $state);
}
elsif (!ref($cases) || ref($cases) =~ /^(?:CODE|Regexp)$/
|| $_DC->is_blesser_of($cases)) {
# Shortcut: scalar, construct the cases. Handle undef as ignore case
$cases = [
[] => defined($cases) ? ref($cases) ? $cases : [$cases] : undef,
];
}
else {
_compile_die($state,
'cases is not an ARRAY, CODE, Regexp, DieCode, scalar or undef: ',
$cases);
}
my(@cases) = @$cases;
$state->{case_num} = 0;
while (@cases) {
_compile_case($state, $tests, splice(@cases, 0, 2));
}
return;
}
sub _compile_object {
my($self, $state, $tests, $object, $methods) = @_;
# Validates $object and sets object info on state. Compiles methods.
$state = _compile_options($state, 'object', $object);
$state->{test} = $self;
if ($state->{class_name}) {
$state->{create_object} = \&default_create_object
unless $state->{create_object};
}
if ($state->{create_object} || ref($state->{object}) eq 'CODE') {
my($fields) = $self->[$_IDI];
$state->{_eval_object} = @{$fields->{_eval_object} ||= []};
push(@{$fields->{_eval_object}}, [
ref($state->{object}) eq 'CODE'
? ($state->{object}, [])
: ($state->{create_object},
ref($state->{object}) eq 'ARRAY' ? $state->{object}
: !ref($state->{object}) ? [$state->{object}]
: _compile_die('object must be a scalar, ARRAY, or CODE',
$state->{object})),
]);
$state->{object} = undef;
$state->{create_object} = undef;
}
elsif (!UNIVERSAL::isa($state->{object}, 'UNIVERSAL')) {
_load_class($state)
if $state->{object} && $state->{object} =~ /(?:\:\:|\.)/;
_compile_die($state, 'object is not a subclass of UNIVERSAL'
. ' (forgot to "use"?) or CODE: ', $state->{object})
unless UNIVERSAL::isa($state->{object}, 'UNIVERSAL');
}
$methods = [
$methods => 1,
] if ref($methods) eq 'CODE';
_compile_assert_even($methods, $state);
$state->{method_num} = 0;
my(@methods) = @$methods;
while (@methods) {
_compile_method($state, $tests, splice(@methods, 0, 2));
}
return;
}
sub _compile_options {
my($state, $which, $entity_or_hash) = @_;
# which is object, method, or case. If entity_or_hash is a hash, the hash
# is parsed for which and the attributes are copied. Any extra attributes
# cause an exception. $which_num is incremented.
_trace('options: ', $entity_or_hash) if $_TRACE;
$state->{$which.'_num'}++;
# Make a copy, so we retain defaults of parent
$state = {%$state};
unless (ref($entity_or_hash) eq 'HASH') {
# No customizations, just set $which
$state->{$which} = $entity_or_hash;
}
else {
# Customizations and $which
my($h) = {%$entity_or_hash};
_compile_die($state, '"', $which, '" must be specified in HASH')
unless $h->{$which};
foreach my $o (@_PLAIN_OPTIONS) {
_add_option($state, $h, $o);
}
foreach my $c (@_CALLBACKS, $which) {
next unless _add_option($state, $h, $c);
next if $c eq $which;
_compile_die($state, $c, ' is not a subroutine (code_ref)')
unless ref($state->{$c}) eq 'CODE';
}
_compile_die($state, 'unknown options: ',
join(' ', sort(keys(%$h))))
if %$h;
}
_trace('state: ', $state) if $_TRACE;
return $state;
}
sub _default_print {
# Prints its arguments to STDOUT.
return print(@_);
}
sub _die {
my(@msg) = @_;
# Calls die for now. Eventually, will tell more.
b_die(@msg);
# DOES NOT RETURN
}
sub _die_stack {
my($actual) = @_;
my($s) = $_D->is_blesser_of($actual) && $actual->unsafe_get('stack');
return $s ? "\n-- begin stack --\n" . $s . "\n-- end stack --\n" : '';
}
sub _eval {
my($self, $tests) = @_;
# Runs the tests as returned from _compile().
my($c) = 0;
my($print) = $self->get_if_exists_else_put(
print => sub {\&_default_print});
$print->('1..' . int(@$tests) . "\n");
my($err);
my($results) = {
failed => [],
passed => [],
};
local($_SELF) = $self;
local($_CASE);
foreach my $case (@$tests) {
$_CASE = $case;
$c++;
my($result);
next
unless _prepare_case($self, $case, \$err);
_trace($case) if $_TRACE;
my($die) = _catch(sub {
if ($case->unsafe_get('want_void')) {
_eval_method($case);
$result = [];
}
else {
$result = [
$case->unsafe_get('want_scalar') ? scalar(_eval_method($case))
: _eval_method($case),
];
}
return;
});
_trace('returned ', $die || $result) if $_TRACE;
if ($die) {
$case->put(
die_code => $die->get('code'),
die => $die,
);
$err = _eval_result($case, $die);
}
elsif (defined($case->unsafe_get('expect'))) {
$case->put(return => $result);
$err = _eval_result($case, $result);
}
else {
_trace('ignoring result') if $_TRACE;
}
}
continue {
push(@{$results->{$err ? 'failed' : 'passed'}}, $c);
$print->($err
? "not ok $c " . $case->as_string . ": $err\n"
: "ok $c\n");
$err = undef;
}
$self->put(%$results);
$print->(
$self->format_results(scalar(@{$results->{passed}}), int(@$tests)),
);
return $self;
}
sub _eval_compute_return {
my($case, $return) = @_;
# Calls compute_return if there is a compute_return on the case, and
# $return is an array_ref.
return undef
unless ref($$return) eq 'ARRAY' && $case->unsafe_get('compute_return');
my($err);
my($new_return) = _eval_custom(
$case,
'compute_return',
[$$return, $case->get('expect')],
\$err,
);
_trace($err || $new_return) if $_TRACE;
return $err
unless $new_return;
$case->put(return => $$return = $new_return);
return undef;
}
sub _eval_custom {
my($case, $which, $params, $err) = @_;
# Returns result of custom call $which (check_return or compute_params).
# If there is an error, $err will be set. Checks for appropriate return
# result in case of compute_params.
#
# $params only needs extra params for check_return only.
my($res);
my($die) = _catch(sub {
$res = $case->get($which)->($case, @$params);
return undef;
});
if ($die) {
$$err = "Error in custom $which: " . $die->as_string . _die_stack($die);
return undef;
}
if ($which =~ /params/ && !(
ref($res) eq 'ARRAY' || ($res || '') eq __PACKAGE__->IGNORE_RETURN
)) {
$$err = 'an array_ref'
}
elsif ($which =~ /object/
&& !(UNIVERSAL::isa($res, 'UNIVERSAL')
|| ($res || '') eq __PACKAGE__->IGNORE_RETURN)
) {
$$err = 'a subclass of UNIVERSAL (forgot to "use"?)';
}
elsif ($which eq 'compute_return' && ref($res) ne 'ARRAY') {
$$err = 'an array_ref';
}
elsif ($which =~ /expect|check_return/
&& (ref($res) ? ref($res) !~ /^(?:ARRAY|Regexp)$/
: defined($res) ? $res !~ /^[01]$/ : 1)) {
$$err = 'an array_ref, Regexp, or boolean (0 or 1)';
}
elsif ($which =~ /die/
&& (ref($res) ? !$_DC->is_blesser_of($res)
: defined($res) ? $res !~ /^[01]$/ : 1)) {
$$err = 'a DieCode or boolean (0 or 1)';
}
else {
return $res;
}
$$err = "$which did not return ${$err}: "
. b_use('IO.Ref')->to_short_string($res);
return undef;
}
sub _eval_method {
my($case) = @_;
# Calls the method based on whether it is a sub or not.
my($object, $method, $params) = $case->get(qw(object method params));
return []
if $params eq __PACKAGE__->IGNORE_RETURN;
return ref($method) eq 'CODE'
? $method->($case, $object, @$params) : $object->$method(@$params);
}
sub _eval_object {
my($self, $case, $err) = @_;
# Returns true if eval worked. Objects are cached.
return $case->get('object')
unless defined(my $e = $case->unsafe_get('_eval_object'));
my($fields) = $self->[$_IDI];
my($object) = $fields->{_eval_object}->[$e];
unless (defined($object)) {
$$err = 'prior create_object call failed';
return 0;
}
if (ref($object) eq 'ARRAY') {
my($code, $param) = @$object;
# Try to load: If it fails, then
unless (_load_class($case)) {
$$err = 'unable to load package ' . $case->get('class_name');
}
else {
$case->put(create_object => $code);
$fields->{_eval_object}->[$e] = $object
= _eval_custom($case, 'create_object', [$param], $err);
}
return 0 if $$err;
}
$case->put(object => $object);
return 1;
}
sub _eval_params {
my($case, $err) = @_;
# Returns true if eval worked.
foreach my $custom (qw(params compute_params)) {
next
unless ref($case->unsafe_get($custom)) eq 'CODE';
my($res) = _eval_custom(
$case, $custom, [$case->get(qw(params method object))], $err);
return 0
if $$err;
$case->put(params => $res);
last;
}
return 1;
}
sub _eval_result {
my($case, $actual) = @_;
# Calls the custom method, if need be.
# Assumes type of result was already verified.
my($custom);
my($show);
my($result, $actual_which) = $_D->is_blesser_of($actual)
? ($actual->get('code'), 'die_code') : ($actual, 'return');
my($expect_which) = $_DC->is_blesser_of($case->get('expect'))
? 'die_code' : 'return';
if ($expect_which eq 'return') {
my($err) = _eval_compute_return($case, \$actual);
return $err
if $err;
$result = $actual;
}
if (ref($case->get('expect')) eq 'CODE') {
# Only on success do we eval a case-specific check_return
$custom = 'expect'
if ref($actual) eq 'ARRAY';
}
elsif ($actual_which eq $expect_which) {
$custom = "check_$expect_which";
$custom = undef
unless $case->unsafe_get($custom);
}
if ($custom) {
#TODO: Move off to separate method
my($err) = undef;
my($res) = _eval_custom(
$case,
$custom, [$actual, $case->get('expect')],
\$err,
);
_trace($case, ' ', $custom, ' returned: ', $res) if $_TRACE;
return $err
if $err;
$custom = 'check_return'
if $custom eq 'expect';
$custom =~ s/^check_//;
if (ref($res)) {
# New value for return or die, save and compare
$case->expect($res);
$result = $case->get($custom);
}
else {
return $res ? undef
: "check_$expect_which returned false for result: "
. b_use('IO.Ref')->to_short_string(
$case->get($actual_which));
}
}
my($e) = $case->get('expect');
if (ref($e) eq 'CODE') {
return "unexpected die: " . b_use('IO.Ref')->to_short_string($result)
. _die_stack($actual);
}
my($x);
my($comparator) = $case->get('comparator');
my($diff_die) = _catch(sub {
$x = b_use('IO.Ref')->$comparator(
$e,
ref($result) eq 'ARRAY' && @$result == 1 && ref($e) eq 'Regexp'
? $result->[0] : $result,
);
});
return $diff_die ? "$comparator died: " . $diff_die->as_string
: $x ? $$x . _die_stack($actual)
: undef;
}
sub _load_class {
my($thing) = @_;
my($is_hash) = !$_U->is_blesser_of($thing);
my($c) = $is_hash ? $thing->{object} : $thing->unsafe_get('class_name');
return 1
unless $c;
return 0
unless $c = $_CL->unsafe_map_require($c);
$is_hash ? $thing->{object} = $c : $thing->put(class_name => $c);
return 1;
}
sub _prepare_case {
my($self, $case, $err) = @_;
# Returns false if err. Calls _eval_object_or_params and
# then checks method.
if (my $ct = $self->unsafe_get_and_delete('case_tag')) {
$case->put(tag => $ct);
}
return 0
unless _eval_object($self, $case, $err) && _eval_params($case, $err);
if ($case->unsafe_get('method_is_autoloaded')
|| UNIVERSAL::can($case->get('object'), $case->get('method'))
|| ref($case->get('method')) eq 'CODE'
) {
$_HANDLERS->call_fifo(handle_prepare_case => [$case]);
return 1;
}
my($o) = $case->get('object');
$$err = $case->get('method') . ': not implemented by ' . (ref($o) || $o)
unless $o eq __PACKAGE__->IGNORE_RETURN;
return 0;
}
1;