Bivio::Test::Language
# Copyright (c) 2001-2008 bivio Software, Inc. All Rights reserved.
# $Id$
package Bivio::Test::Language;
use strict;
use Bivio::Base 'Collection.Attributes';
use Bivio::IO::Trace;
my($_IDI) = __PACKAGE__->instance_data_index;
our($_SELF_IN_EVAL);
Bivio::IO::Config->register(my $_CFG = {
log_dir => 'log',
});
my($_INLINE) = 'inline00000';
my($_R) = __PACKAGE__->use('IO.Ref');
my($_F) = __PACKAGE__->use('IO.File');
our($_TRACE);
my($_DT) = __PACKAGE__->use('Type.DateTime');
sub DESTROY {
# You probably don't want to define a DESTROY method. Instead create a
# L<handle_cleanup|"handle_cleanup">.
#
# Subclasses should implement:
#
# sub DESTROY {
# my($self) = @_;
# my destroy code....
# return $self->SUPER::DESTROY;
# }
return;
}
sub assert_in_eval {
shift;
return _assert_in_eval(@_);
}
sub handle_cleanup {
my($self) = @_;
# Processes cleanup arguments. See L<test_cleanup|"test_cleanup">.
# Inverse operation of L<handle_setup|"handle_setup">.
#
# Test language classes should implement:
#
# sub handle_cleanup {
# my($self, @cleanup_args) = @_;
# my cleanup up...;
# return $self->SUPER::handle_cleanup;
# }
#
# All values will be deleted.
$self->delete_all;
return;
}
sub handle_config {
my(undef, $cfg) = @_;
# log_dir : string [log]
#
# Subdir of test which contains log files. The log files are prefixed with the
# test name.
$_CFG = $cfg;
return;
}
sub handle_setup {
# Processes setup arguments. See L<test_setup|"test_setup">.
#
# Test language classes should implement:
#
# sub handle_setup {
# my($self, @setup_args) = @_;
# $self->SUPER::handle_setup;
# my setup up...;
# return;
# }
return;
}
sub new {
my($proto, $attrs) = @_;
# Instantiates this class.
my($self) = $proto->SUPER::new($attrs);
$self->[$_IDI] = {};
return $self;
}
sub test_cleanup {
my($proto, $die) = _args(@_);
# Clean up state, such as external files, database values, etc.
# Must not rely on state of instance, but be able to clean up globally.
#
# This method is called automatically at the end of every test script.
#
# See L<handle_cleanup|"handle_cleanup"> for what subclasses should implement.
return $proto->handle_cleanup($die);
}
sub test_conformance {
# Turn off deviance testing mode. See also L<test_deviance|"test_deviance">.
_assert_in_eval('test_setup')->delete('test_deviance');
return;
}
sub test_deviance {
# Sets up test for deviance testing. Expect all functions to fail. If I<regex>
# supplied, expect the exception (L<Bivio::Die|Bivio::Die>)
# to contain I<regex>. If I<regex> is a
# string, will be compiled with qr/$regex/is. See also
# L<test_conformance|"test_conformance">
if (ref($_[1]) eq 'CODE') {
_do_deviance(@_);
}
else {
my(undef, $regex) = _args(@_);
_assert_in_eval('test_setup')->put(test_deviance =>
ref($regex) ? $regex : defined($regex) ? qr/$regex/is : qr//);
}
return;
}
sub test_equals {
my($self, $expect, $actual) = _args(@_);
# Asserts I<expect> and I<actual> are identical.
return unless my $d = $_R->nested_differences($expect, $actual);
_die($self, $$d);
# DOES NOT RETURN
}
sub test_log_output {
my(undef, $file_name, $content) = _args(@_);
# Writes output to a separate log file in I<test_log_prefix> directory. Returns
# the file name that was written or undef if no file was written (no
# I<test_log_prefix>).
return unless $_SELF_IN_EVAL;
my($self) = _assert_in_eval('test_log_output');
return unless ref($self) && $self->unsafe_get('test_log_prefix');
# ignore wide-print warnings
local($SIG{__WARN__}) = sub {};
return $_F->write(
$self->get('test_log_prefix') . "/$file_name",
ref($content) ? $content : \$content,
);
}
sub test_name {
# Returns the basename of the test_script.
return File::Basename::basename(
_assert_in_eval('test_name')->get('test_script'), '.btest');
}
sub test_now {
return $_DT->now_as_file_name;
}
sub test_ok {
my($self, $cond, @msg) = _args(@_);
return $cond || _die($self, @msg);
}
sub test_run {
my($proto, $script) = @_;
# Runs a script. Cannot be called from within a script. Returns undef if
# everything goes ok. Otherwise, returns the die instance created by the script.
b_use('Bivio.ShellUtil')->shell_util_request_instance;
local($_SELF_IN_EVAL);
my($script_name) = ref($script) ? $_INLINE++ : $script;
my($die) = Bivio::Die->catch(sub {
_die($_SELF_IN_EVAL, 'called ', $script_name,
' from within test script')
if $_SELF_IN_EVAL;
$_SELF_IN_EVAL = $proto->new({test_script => $script_name});
$script = $_F->read($script_name)
unless ref($script);
substr($$script, 0, 0)
= 'use strict;package ' . b_use('Test.LanguageWrapper') . ';';
my($die) = Bivio::Die->catch($script);
_trace($die) if $_TRACE;
return unless $die;
$_SELF_IN_EVAL->test_log_output('test_run.err',
$die->as_string . "\n" . $die->get('stack'))
if $_SELF_IN_EVAL;
$die->throw;
# DOES NOT RETURN
});
_trace($die) if $_TRACE;
Bivio::Die->eval(sub {$_SELF_IN_EVAL->test_cleanup($die)});
_find_line_number($die, $script_name) if $die;
_trace($script, ' ', $die) if $die && $_TRACE;
return $die;
}
sub test_script {
# Returns name of test script.
return _assert_in_eval('test_script')->get('test_script');
}
sub test_self {
return _assert_in_eval('test_self');
}
sub test_setup {
my($proto, $map_class, @setup_args) = @_;
# Loads TestLanguage I<map_class>. Calls L<new|"new"> on the loaded class and
# then calls L<handle_setup|"handle_setup"> with I<setup_args> on newly created
# test instance.
my($self) = _assert_in_eval('test_setup');
_die($proto, 'called test_setup() twice') if $self->[$_IDI]->{setup_called}++;
my($subclass) = $proto->use('TestLanguage', $map_class);
_die($proto, "$subclass is not a ", __PACKAGE__, ' class')
unless $subclass->isa(__PACKAGE__);
_trace($subclass, ' setup with ', \@setup_args) if $_TRACE;
my($new_self) = $subclass->new;
_die($proto, "$subclass\->new didn't create an instance of ", __PACKAGE__)
unless $new_self->isa(__PACKAGE__);
$new_self->put(
test_script => $self->get('test_script'),
test_log_prefix => _log_prefix($self->get('test_script')),
);
$_SELF_IN_EVAL = $new_self;
_trace($_SELF_IN_EVAL);
$_SELF_IN_EVAL->handle_setup(@setup_args);
return $_SELF_IN_EVAL;
}
sub test_template {
my(undef, $template) = _args(@_);
my($self) = _assert_in_eval('test_template');
return ${$self->use('IO.Template')->replace_in_file(
$self->test_name . "/$template",
$self->test_template_vars,
)};
}
sub test_template_vars {
my(undef, $vars) = _args(@_);
my($self) = _assert_in_eval('test_template_vars');
$self->put(test_template_vars => $vars)
if $vars;
return $self->get('test_template_vars');
}
sub test_use {
my($self, $class) = _args(@_);
return $self->use($class);
}
sub _args {
# Detects if first argument is $proto or not. When view_*() methods
# are called from view files or templates, they are not given a $proto.
return defined($_[0]) && UNIVERSAL::isa(ref($_[0]) || $_[0], __PACKAGE__)
? @_ : (__PACKAGE__, @_);
}
sub _assert_in_eval {
my($op) = @_;
# Returns the current test or terminates.
Bivio::Die->die($op, ': attempted operation outside test script')
unless $_SELF_IN_EVAL;
return $_SELF_IN_EVAL;
}
sub _die {
my(undef, @msg) = @_;
# Call die with appropriate prefix.
Bivio::Die->die(@msg);
# DOES NOT RETURN
}
sub _do_deviance {
my($self, $dev_block, $regex) = @_;
$regex = defined($regex) ? qr/$regex/is : qr//
unless ref($regex);
my($die) = Bivio::Die->catch($dev_block);
_die($self, ' deviance call "', $regex, '" failed to die.')
unless $die;
_die($self, ' deviance call failed with "',
$die, '" but did not match pattern: ', $regex)
unless $die->as_string =~ $regex;
return;
}
sub _find_line_number {
my($die, $script_name) = @_;
# Find the line number of error in the test script.
return unless my($stack) = $die->get('stack');
my($line) = $stack =~ /.* at \(eval \d+\) line (\d+)\s+Bivio::Test::Language::__ANON__/s;
substr($die->get('attrs')->{message}, 0, 0) = "$script_name, line $line: "
if $line;
return;
}
sub _log_prefix {
my($script_name) = @_;
# Parses test_script and writes log prefix.
my($v, $d, $f) = File::Spec->splitpath(File::Spec->rel2abs($script_name));
$f =~ s/(?<=.)\.[^\.]+$//g;
return $_F->mkdir_p(
$_F->rm_rf(
File::Spec->catpath(
'',
File::Spec->catpath(
$v, $d, $_CFG->{log_dir}),
$f)));
}
1;