use 5.10.0;
our $VERSION = '0.90';
has 'test_configuration' => (
is => 'ro',
isa => 'Test::Class::Moose::Config',
required => 1,
);
has 'test_report' => (
is => 'ro',
isa => 'Test::Class::Moose::Report',
builder => '_build_test_report',
);
sub runtests {
my $self = shift;
my $report = $self->test_report;
$report->_start_benchmark;
my @test_classes = $self->test_classes;
$self->_validate_test_classes(@test_classes);
context_do {
my $ctx = shift;
$ctx->plan( scalar @test_classes );
$self->_run_test_classes(@test_classes);
$ctx->diag(<<"END") if $self->test_configuration->statistics;
Test classes: @{[ $report->num_test_classes ]}
Test instances: @{[ $report->num_test_instances ]}
Test methods: @{[ $report->num_test_methods ]}
Total tests run: @{[ $report->num_tests_run ]}
END
$ctx->done_testing;
};
$report->_end_benchmark;
return $self;
}
sub _validate_test_classes {
my $self = shift;
my @bad = grep { !$_->isa('Test::Class::Moose') } @_
or return;
my $msg = 'Found the following class';
$msg .= 'es' if @bad > 1;
$msg
.= ' that '
. ( @bad > 1 ? 'are' : 'is' ) . ' not '
. ( @bad > 1 ? 'subclasses' : 'a subclass' )
. " of Test::Class::Moose: @bad";
$msg .= ' (did you load '
. ( @bad > 1 ? 'these classes' : 'this class' ) . '?)';
die $msg;
}
sub _run_test_classes {
my $self = shift;
my @test_classes = @_;
for my $test_class (@test_classes) {
async_subtest(
$test_class,
{ manual_skip_all => 1 },
sub { $self->_run_test_class($test_class) }
)->finish;
}
}
sub _build_test_report {
my $self = shift;
return Test::Class::Moose::Report->new(
is_parallel => ( ref $self ) =~ /::Parallel$/ ? 1 : 0,
);
}
sub _run_test_class {
my $self = shift;
my $test_class = shift;
my $class_report
= Test::Class::Moose::Report::Class->new( name => $test_class );
$self->test_report->add_test_class($class_report);
$class_report->_start_benchmark;
my $passed = $self->_run_test_instances( $test_class, $class_report );
$class_report->passed($passed);
$class_report->_end_benchmark;
return $class_report;
}
sub _run_test_instances {
my $self = shift;
my $test_class = shift;
my $class_report = shift;
my @test_instances = $test_class->_tcm_make_test_class_instances(
test_report => $self->test_report,
);
unless (@test_instances) {
context_do {
my $ctx = shift;
my $message = "Skipping '$test_class': no test instances found";
$class_report->skipped($message);
$class_report->passed(1);
$ctx->plan( 0, 'SKIP' => $message );
};
return 1;
}
return context_do {
my $ctx = shift;
$ctx->plan( scalar @test_instances )
if @test_instances > 1;
my $passed = 1;
for my $test_instance (
sort { $a->test_instance_name cmp $b->test_instance_name }
@test_instances )
{
my $instance_report = $self->_maybe_wrap_test_instance(
$class_report,
$test_instance,
@test_instances > 1,
);
$passed = 0 if not $instance_report->passed;
}
return $passed;
};
}
sub _maybe_wrap_test_instance {
my $self = shift;
my $class_report = shift;
my $test_instance = shift;
my $in_subtest = shift;
return $self->_run_test_instance(
$class_report,
$test_instance,
) unless $in_subtest;
my $instance_report;
async_subtest(
$test_instance->test_instance_name,
{ manual_skip_all => 1 },
sub {
$instance_report = $self->_run_test_instance(
$class_report,
$test_instance,
);
},
)->finish;
return $instance_report;
}
sub _run_test_instance {
my ( $self, $class_report, $test_instance ) = @_;
my $test_instance_name = $test_instance->test_instance_name;
my $instance_report = Test::Class::Moose::Report::Instance->new(
{ name => $test_instance_name,
}
);
local $0 = "$0 - $test_instance_name"
if $self->test_configuration->set_process_name;
$instance_report->_start_benchmark;
$class_report->add_test_instance($instance_report);
my @test_methods = $self->_test_methods_for($test_instance);
context_do {
my $ctx = shift;
unless (@test_methods) {
my $message
= "Skipping '$test_instance_name': no test methods found";
$instance_report->skipped($message);
$instance_report->passed(1);
$ctx->plan( 0, SKIP => $message );
return;
}
my $report = $self->test_report;
unless (
$self->_run_test_control_method(
$test_instance, 'test_startup', $instance_report,
)
)
{
$instance_report->passed(0);
return;
}
if ( my $message = $test_instance->test_skip ) {
$instance_report->skipped($message);
if ( $test_instance->run_control_methods_on_skip ) {
$self->_run_shutdown( $test_instance, $instance_report )
or return;
}
$instance_report->passed(1);
$ctx->plan( 0, SKIP => $message );
return;
}
$ctx->plan( scalar @test_methods );
my $all_passed = 1;
foreach my $test_method (@test_methods) {
my $method_report = $self->_run_test_method(
$test_instance,
$test_method,
$instance_report,
$ctx,
);
$all_passed = 0 if not $method_report->passed;
}
$instance_report->passed($all_passed);
$self->_run_shutdown( $test_instance, $instance_report );
$instance_report->_end_benchmark;
if ( $self->test_configuration->show_timing ) {
my $time = $instance_report->time->duration;
$ctx->diag("$test_instance_name: $time");
}
};
return $instance_report;
}
sub _run_shutdown {
my ( $self, $test_instance, $instance_report ) = @_;
return 1
if $self->_run_test_control_method(
$test_instance, 'test_shutdown', $instance_report,
);
$instance_report->passed(0);
return 0;
}
sub _test_methods_for {
my ( $self, $thing ) = @_;
my @filtered = $self->_filtered_test_methods($thing);
return uniq(
$self->test_configuration->randomize
? shuffle(@filtered)
: sort @filtered
);
}
sub _filtered_test_methods {
my ( $self, $thing ) = @_;
my @method_list = $thing->test_methods;
if ( my $include = $self->test_configuration->include ) {
@method_list = grep {/$include/} @method_list;
}
if ( my $exclude = $self->test_configuration->exclude ) {
@method_list = grep { !/$exclude/ } @method_list;
}
my $test_class = ref $thing ? $thing->test_class : $thing;
return $self->_filter_by_tag(
$test_class,
\@method_list
);
}
sub _filter_by_tag {
my ( $self, $class, $methods ) = @_;
my @filtered_methods = @$methods;
if ( my $include = $self->test_configuration->include_tags ) {
my @new_method_list;
foreach my $method (@filtered_methods) {
foreach my $tag (@$include) {
if (Test::Class::Moose::AttributeRegistry->method_has_tag(
$class, $method, $tag
)
)
{
push @new_method_list => $method;
}
}
}
@filtered_methods = @new_method_list;
}
if ( my $exclude = $self->test_configuration->exclude_tags ) {
my @new_method_list = @filtered_methods;
foreach my $method (@filtered_methods) {
foreach my $tag (@$exclude) {
if (Test::Class::Moose::AttributeRegistry->method_has_tag(
$class, $method, $tag
)
)
{
@new_method_list
= grep { $_ ne $method } @new_method_list;
}
}
}
@filtered_methods = @new_method_list;
}
return @filtered_methods;
}
my %TEST_CONTROL_METHODS = map { $_ => 1 } qw/
test_startup
test_setup
test_teardown
test_shutdown
/;
sub _run_test_control_method {
my ( $self, $test_instance, $phase, $report_object ) = @_;
local $0 = "$0 - $phase"
if $self->test_configuration->set_process_name;
$TEST_CONTROL_METHODS{$phase}
or croak("Unknown test control method ($phase)");
my %report_args = (
name => $phase,
instance => (
$report_object->isa('Test::Class::Moose::Report::Method')
? $report_object->instance
: $report_object
)
);
my $phase_method_report
= Test::Class::Moose::Report::Method->new( \%report_args );
my $set_meth = "set_${phase}_method";
$report_object->$set_meth($phase_method_report);
$phase_method_report->_start_benchmark;
my $success = context_do {
my $ctx = shift;
return try {
my $count = $ctx->hub->count;
$test_instance->$phase($report_object);
croak "Tests may not be run in test control methods ($phase)"
unless $count == $ctx->hub->count;
1;
}
catch {
my $error = $_;
my $class = $test_instance->test_class;
$ctx->ok( 0, "$class->$phase failed", [$error] );
0;
};
};
$phase_method_report->_end_benchmark;
return $success;
}
sub _run_test_method {
my ( $self, $test_instance, $test_method, $instance_report ) = @_;
local $0 = "$0 - $test_method"
if $self->test_configuration->set_process_name;
my $method_report = Test::Class::Moose::Report::Method->new(
{ name => $test_method, instance => $instance_report } );
$instance_report->add_test_method($method_report);
$test_instance->test_skip_clear;
$self->_run_test_control_method(
$test_instance,
'test_setup',
$method_report,
);
$method_report->_start_benchmark;
my $num_tests = 0;
my $test_class = $test_instance->test_class;
context_do {
my $ctx = shift;
my $skipped;
my $p = async_subtest(
$test_method,
{ manual_skip_all => 1 },
sub {
my $hub = test2_stack()->top;
if ( my $message = $test_instance->test_skip ) {
$method_report->skipped($message);
context_do {
shift->plan( 0, SKIP => $message );
};
$skipped = 1;
return 1;
}
$test_instance->$test_method($method_report);
$num_tests = $hub->count;
},
)->finish;
$method_report->_end_benchmark;
if ( $self->test_configuration->show_timing ) {
my $time = $method_report->time->duration;
$ctx->diag( $method_report->name . ": $time" );
}
$method_report->passed( $p ? 1 : 0 );
unless ( $skipped && !$test_instance->run_control_methods_on_skip ) {
$self->_run_test_control_method(
$test_instance,
'test_teardown',
$method_report,
) or $method_report->passed(0);
}
return $p;
};
return $method_report unless $num_tests && !$method_report->is_skipped;
$method_report->num_tests_run($num_tests);
$method_report->tests_planned($num_tests)
unless $method_report->has_plan;
return $method_report;
}
sub test_classes {
my $self = shift;
if ( my $classes = $self->test_configuration->test_classes ) {
return @{$classes} if @{$classes};
}
my %metaclasses = Class::MOP::get_all_metaclasses();
my @classes;
foreach my $class ( keys %metaclasses ) {
next if $class eq 'Test::Class::Moose';
push @classes => $class if $class->isa('Test::Class::Moose');
}
if ( $self->test_configuration->randomize_classes ) {
return shuffle(@classes);
}
return sort @classes;
}
1;