File Coverage

blib/lib/TAP/Harness/Archive/MultipleHarnesses.pm

Criterion	Covered	Total	%
statement	79	81	97.5
branch	20	26	76.9
condition			n/a
subroutine	7	7	100.0
pod	1	1	100.0
total	107	115	93.0

package TAP::Harness::Archive::MultipleHarnesses;
use strict;
use base 'TAP::Harness::Archive';
use File::Path;
use File::Spec;
use lib qw( ./lib );
use TAP::Harness::ReportByDescription;
our $VERSION = '0.06';

sub runtests {
    my ($self, $targetsref, @files) = @_;

    # tell TAP::Harness to put the raw tap someplace we can find it later
    my $dir = $self->{__archive_tempdir};
    $ENV{PERL_TEST_HARNESS_DUMP_TAP} = $dir;

    # get some meta information about this run
    my @test_labels = ();
    foreach my $subharness (@{$targetsref}) {
        my %har = %$subharness;
        my @tests = @{$har{tests}};
        foreach my $test (@tests) {
            push @test_labels, $test->[1];
        }
    }
    my %meta = (
        file_order => \@test_labels,
        start_time => time(),
    );

    my $aggregator = TAP::Parser::Aggregator->new;

    $aggregator->start();
    foreach my $set (@{$targetsref}) {
        # rewrite environment
        &{$set->{rule}} if defined $set->{rule};
        my $harness = TAP::Harness::ReportByDescription->new();
        $harness->aggregate_tests($aggregator, @{$set->{tests}});
    }
    $aggregator->stop();

    $meta{stop_time} = time();

    my @parsers = $aggregator->parsers;
    for ( my $i = 0; $i < @parsers; $i++ ) {
        $parsers[ $i ] = {
            start_time  => $parsers[ $i ]->start_time,
            end_time    => $parsers[ $i ]->end_time,
            description => $test_labels[ $i ],
        };
    }
    $meta{file_attributes} = \@parsers;

    my $cwd         = Cwd::getcwd();
    my $is_dir      = $self->{__archive_is_directory};
    my ($archive, $output_file);
    if( $is_dir ) {
        $output_file = $self->{__archive_tempdir};
    }
    else {
        $output_file = $self->{__archive_file};

        # go into the dir so that we can reference files
        # relatively and put them in the archive that way
        chdir($dir) or $self->_croak("Could not change to directory $dir: $!");

        unless (File::Spec->file_name_is_absolute($output_file)) {
            $output_file = File::Spec->catfile($cwd, $output_file);
        }

        # create the archive
        $archive = Archive::Tar->new();
        $archive->add_files($self->_get_all_tap_files);
        chdir($cwd) or $self->_croak("Could not return to directory $cwd: $!");
    }

    # add in any extra files
    if(my $x_files = $self->{__archive_extra_files}) {
        my @rel_x_files;
        foreach my $x_file (@$x_files) {
            # handle both relative and absolute file names
            my $rel_file;
            if( File::Spec->file_name_is_absolute($x_file) ) {
                $rel_file = File::Spec->abs2rel($x_file, $cwd);
            }
            else {
                $rel_file = $x_file;
            }
            push(@rel_x_files, $rel_file);
        }
        $archive->add_files(@rel_x_files) unless $is_dir;
        $meta{extra_files} = \@rel_x_files;
    }

    # add any extra_properties to the meta
    if(my $extra_props = $self->{__archive_extra_props}) {
        $meta{extra_properties} = $extra_props;
    }

    # create the YAML meta file
    my $yaml = YAML::Tiny->new();
    $yaml->[0] = \%meta;
    if( $is_dir ) {
        my $meta_file = File::Spec->catfile($output_file, 'meta.yml');
        open(my $out, '>', $meta_file) or die "Could not create meta.yml: $!";
        print $out $yaml->write_string;
        close($out);
    }
    else {
        $archive->add_data('meta.yml', $yaml->write_string);
        $archive->write($output_file, $self->{__archive_format} eq 'tar.gz') or die $archive->errstr;
        # be nice and clean up
        File::Path::rmtree($dir);
    }

    print "\nTAP Archive created at $output_file\n"
        unless $self->{formatter}->{verbosity} < -1;

    return $aggregator;
}

1;

=head1 NAME

TAP::Harness::Archive::MultipleHarnesses - Create an archive of multiple
harnesses of TAP test results

=cut

=head1 SYNOPSIS

    use TAP::Harness::Archive::MultipleHarnesses;
    my $archive = TAP::Harness::Archive::MultipleHarnesses->new(\%args);
    $archive->runtests(\@targets);

=head1 DESCRIPTION

This package subclasses Michael Peters' TAP::Harness::Archive package from
CPAN.  It provides its own C method for the case where you need to
create an archive of test results generated by running multiple harnesses
sequentially.

For a discussion of use cases for this functionality, see the documentation
for TAP::Harness::ReportByDescription.

    perldoc TAP::Harness::ReportByDescription

=head1 METHODS

=head2 C

Inherited from Test::Harness::Archive.

=head2 C

Replaces C.  B
different from other packages' C interface:  It takes a reference
to an array of hash references rather than a simple array.>

Each hash reference holds information on how a particular set of tests is to
be run.  The various sets are run and placed into the archive in the order in
which they appear in the array.

Each hash reference needs three elements:

=over 4

=item * C

A list of tests to be run (typically expressed as a list of file glob
patterns).

=item * C

A reference to a subroutine which will be run before a given set of tests is
executed.   The purpose of this subroutine is to set up the environmental
variables as needed for a particular subharness.

=item * C

A string describing a particular subharness which will be combined with a
particular test file's name to form the description of the test both in STDOUT
and in the test archive.

=back

=head2 C

Inherited from Test::Harness::Archive.

=head1 EXAMPLE

Adapted (simplified) from Parrot's C.

    use Parrot::Harness::Smoke qw( collect_test_environment_data );
    use TAP::Harness::Archive::MultipleHarnesses;

    sub set_runcore_target {
        my ($target)  = @_;
        return {
            label   => "test$target",
            rule    => sub { set_runcore_environmental_args($target) },
            tests   => [
                        map { [ $_, "test${alt}__$_", ] }
                            @Parrot::Harness::TestSets::runcore_test_files
                       ],
        };
    }
    my @targets = map { set_runcore_target($_) } ( qw| b f r | );
    my %env_data = collect_test_environment_data();

    my $archive = TAP::Harness::Archive::MultipleHarnesses->new( {
        verbosity        => $ENV{HARNESS_VERBOSE},
        archive          => 'parrot_test_run.tar.gz',
        merge            => 1,
        jobs             => $ENV{TEST_JOBS} || 1,
        extra_properties => \%env_data,
        extra_files      => [ 'myconfig', 'config_lib.pir' ],
    } );
    my $overall_aggregator = $archive->runtests(\@targets);
    $archive->summary($overall_aggregator);

=head1 AUTHOR

This code was derived from Michael Peters' Test::Harness::Archive distribution
on CPAN, as well as examples in the documentation for TAP::Harness,
TAP::Parser, TAP::Parser::Aggregator and other CPAN modules.  Documentation
and code assemblage by James E Keenan.

=head1 LICENSE

This is free software and is released under the same terms as Perl itself.

=cut

# vim:ts=4:sw=4:et:sta