package Test::Class::Moose::Executor::Parallel;
$Test::Class::Moose::Executor::Parallel::VERSION = '0.58';
# ABSTRACT: Execute tests in parallel (parallelized by instance)
use 5.10.0;
use Moose 2.0000;
use Carp;
use namespace::autoclean;
with 'Test::Class::Moose::Role::Executor';
use List::MoreUtils qw(none);
use Parallel::ForkManager;
use TAP::Stream 0.44;
use Test::Builder;
use Test::Class::Moose::AttributeRegistry;
use List::MoreUtils qw(uniq);
has 'jobs' => (
is => 'ro',
isa => 'Int',
required => 1,
);
has 'color_output' => (
is => 'ro',
isa => 'Bool',
required => 1,
);
has '_color' => (
is => 'rw',
isa => 'TAP::Formatter::Color',
lazy_build => 1,
);
my $run_instance = sub {
my ( $self, $test_instance_name, $test_instance ) = @_;
my $builder = Test::Builder->new;
my $output;
$builder->output( \$output );
$builder->failure_output( \$output );
$builder->todo_output( \$output );
$self->_tcm_run_test_instance( $test_instance_name, $test_instance );
return $output;
};
sub runtests {
my $self = shift;
local $Test::Builder::Level = $Test::Builder::Level + 4;
my $jobs = $self->jobs;
# We need to fetch this output handle before forking off jobs. Otherwise,
# we lose our test builder output if we have a sequential job after the
# parallel jobs. This happens because we explicitly set the builder's
# output to a scalar ref in our $run_instance sub above.
my $test_builder_output = Test::Builder->new->output;
my $stream = TAP::Stream->new;
my $fork = $self->_make_fork_manager($stream);
my @sequential;
$self->_run_parallel_jobs($fork, \@sequential);
for my $pair (@sequential) {
my $output = $self->$run_instance( @{$pair} );
$stream->add_to_stream( TAP::Stream::Text->new(
text => $output,
name => "Sequential tests for $pair->[0] run after parallel tests",
) );
}
# this prevents overwriting the line of dots output from
# $RUN_TEST_CONTROL_METHOD
print STDERR "\n";
# this is where we print the TAP results
print $test_builder_output $stream->to_string;
return $self;
}
sub _make_fork_manager {
my ( $self, $stream ) = @_;
my $fork = Parallel::ForkManager->new($self->jobs);
$fork->run_on_finish(
sub {
my ($pid, $exit_code, $ident, $exit_signal, $core_dump,
$result
) = @_;
if ( defined($result) ) {
my ( $job_num, $tap ) = @$result;
$stream->add_to_stream(
TAP::Stream::Text->new( text => $tap, name => "Job #$job_num (pid: $pid)" ) );
}
else
{ # problems occuring during storage or retrieval will throw a warning
carp("No TAP received from child process $pid!");
}
}
);
return $fork;
}
sub _run_parallel_jobs {
my ( $self, $fork, $sequential ) = @_;
my @test_classes = $self->test_classes;
my $job_num = 0;
foreach my $test_class ( $self->test_classes ) {
my %test_instances
= $test_class->_tcm_make_test_class_instances(
$self->test_configuration->args );
foreach my $test_instance_name (sort keys %test_instances) {
my $test_instance = $test_instances{$test_instance_name};
if ( $self->_test_instance_is_parallelizable($test_instance) ) {
$job_num++;
my $pid = $fork->start and next;
my $output = $self->$run_instance(
$test_instance_name,
$test_instance
);
$fork->finish( 0, [ $job_num, $output ] );
}
else {
push @{$sequential}, [$test_instance_name, $test_instance];
}
}
}
$fork->wait_all_children;
return;
}
sub _test_instance_is_parallelizable {
my ( $self, $test_instance ) = @_;
my $test_class = $test_instance->test_class;
return none {
Test::Class::Moose::AttributeRegistry->method_has_tag(
$test_class,
$_,
'noparallel'
);
}
$self->_tcm_test_methods_for_instance($test_instance);
}
after '_tcm_run_test_method' => sub {
my $self = shift;
my $config = $self->test_configuration;
my $builder = $config->builder;
# we're running under parallel testing, so rather than having
# the code look like it's stalled, we'll output a dot for
# every test method.
my ( $color, $text )
= ( $builder->details )[-1]{ok}
? ( 'green', '.' )
: ( 'red', 'X' );
# The set_color() method from Test::Formatter::Color is just ugly.
if ( $self->color_output ) {
$self->_color->set_color(
sub { print STDERR shift, $text },
$color,
);
$self->_color->set_color( sub { print STDERR shift }, 'reset' );
}
else {
print STDERR $text;
}
};
sub _build__color {
return TAP::Formatter::Color->new;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Class::Moose::Executor::Parallel - Execute tests in parallel (parallelized by instance)
=head1 VERSION
version 0.58
=head1 AUTHOR
Curtis "Ovid" Poe <ovid@cpan.org>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Curtis "Ovid" Poe.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut