package TB2::Module;
use 5.008001;
use TB2::Mouse;
with 'TB2::CanTry',
'TB2::CanLoad';
our $VERSION = '1.005000_006';
our $CLASS = __PACKAGE__;
use base 'Exporter';
our @EXPORT = qw(install_test builder);
sub import {
my $class = shift;
my $caller = caller;
$class->export_to_level(1, $class, @EXPORT);
$class->load('Test::Builder2');
no strict 'refs';
# XXX Don't like doing this. Haven't found a better way.
unshift @{$caller .'::ISA'}, 'Exporter';
# Give them the import() routine for modules.
*{$caller .'::import'} = \&_module_import;
# And their own Builder convenience function
*{$caller .'::Builder'} = sub () {
return Test::Builder2->default;
};
}
sub _module_import {
my $class = shift;
my $caller = caller;
my @input = @_;
push @input, 1 if defined $input[0] and $input[0] eq 'no_plan';
if( @input ) {
$class->Builder->test_start;
$class->Builder->set_plan(@input);
}
$class->export_to_level(1, $class);
}
=head1 NAME
TB2::Module - Write a test module
=head1 SYNOPSIS
use TB2::Module;
our @EXPORT = qw(is);
# is( $have, $want, $name );
install_test( is => sub ($$;$) {
my($have, $want, $name) = @_;
my $result = Builder->ok($have eq $want, $name);
$result->diag([
have => $have,
want => $want
]);
return $result;
});
=head1 DESCRIPTION
A module to declare test functions to make writing a test library easier.
=head2 FUNCTIONS
=head3 install_test
install_test( $name => $code );
Declares a new test function (aka an "assert") or method. Similar to
writing C<< sub name { ... } >> with two differences.
1. Declaring the test in this manner enables the assert_start and
assert_end hooks, such as aborting the test on failure.
2. It takes care of displaying the test result for you.
3. The C<< Builder >> object is available inside your $code which is just
a shortcut for C<< Test::Builder2->default >>.
The prototype of the $code is honored.
$code must return a single TB2::Result::Base object,
usually the result from C<< Test::Builder2->ok() >> or any other test
function.
=cut
sub _install {
my($package, $name, $code) = @_;
no strict 'refs';
*{$package . '::' . $name} = $code;
return;
}
sub install_test {
my($name, $test_code) = @_;
my $caller = caller;
my $proto = prototype($test_code);
$proto = $proto ? "($proto)" : "";
local($@, $!);
my $code = eval sprintf <<'CODE', $proto;
sub %s {
# Fire any before-test actions.
$caller->Builder->assert_start();
# Guard against an assert dying...
my @args = @_;
my($result, $error) = $CLASS->try( sub {
return $test_code->(@args);
});
# ...because we have to pop the assert stack on matter what
$caller->Builder->assert_end($result);
# ...then rethrow the error
die $error if $error;
return $result;
};
CODE
die $@ unless $code;
_install($caller, $name, $code);
return $code;
}
# End the test if it has been started (or if someone else started it)
END {
my $builder = eval { Test::Builder2->default; };
_do_ending($builder) if $builder;
}
sub _do_ending {
my $builder = shift;
my $history = $builder->history;
$builder->test_end if $history->in_test;
}
1;