File Coverage

lib/Module/Build/TestReporter.pm

Criterion	Covered	Total	%
statement	43	117	36.7
branch	1	22	4.5
condition	7	14	50.0
subroutine	12	19	63.1
pod	0	7	0.0
total	63	179	35.2

package Module::Build::TestReporter;

use strict;
use warnings;

use vars '$VERSION';

$VERSION = '1.00';

use base 'Module::Build';
use Scalar::Util          'reftype';
use File::Spec::Functions qw( devnull catdir );

# if these subs had real names, they'd confuse caller() in SUPER.pm
# making them anonymous and assigning to *__ANON__ fixes that
# this is the "You don't have all of MBTR's dependencies installed" constructor
sub fake_new
{
	return sub
	{
		local *__ANON__    = 'new';
		my ($class, %args) = @_;

		my $requires                 = $args{build_requires} ||= {};
		$requires->{'SUPER'}                                 ||= '1.10';
		$requires->{'IPC::Open3'}                            ||= '';
		$requires->{'Class::Roles'}                          ||= '';
		$requires->{'Test::Harness'}                         ||= '2.47';

		Module::Build->new( %args );
	};
}

# this is the "Everything looks good!" constructor
sub new
{
	my ($class, %args) = @_;
	my $report_file    = delete $args{report_file}   || 'test_failures.txt';
	my $report_address = delete $args{report_address}|| '';
	my $self           = $class->SUPER( %args );

	$self->notes( report_file    => $report_file    );
	$self->notes( report_address => $report_address ) if $report_address;

	return $self;
}

BEGIN
{
	eval
	{
		require SUPER;
		require IPC::Open3;

		require Test::Harness::Straps;
		require Class::Roles;

		IPC::Open3->import();
		Class::Roles->import(
			role => [qw(
				new ACTION_test find_test_files save_failure_details
				report_failures write_report
			)]
		);
	};

	if ($@)
	{
		no strict 'refs';
		no warnings 'redefine';
		*{ 'new' } = fake_new();
	}
}

sub ACTION_test
{
	my $self    = shift;

	# don't let Module::Build::Base whine about missing tests
	open( my $fh, '>' . devnull() );

	my $oldfh = select( $fh );
	unless (reftype( $oldfh ))
	{
		no strict 'refs';
		$oldfh = \*$oldfh;
	}
	$self->notes( 'test_oldfh' => $oldfh );

	$self->SUPER( @_ );

	# now let it whine
	select( $self->notes( 'test_oldfh' ) );
}

sub find_test_files
{
	my $self  = shift;
	my $strap = Test::Harness::Straps->new();
	my $outfh = $self->notes( 'test_oldfh' );

	$self->notes( test_failures => [] );

	# XXX: this doesn't work
	my $p = $self->{properties};
	local @INC =
	(
		 ( map { catdir( $p->{base_dir}, $self->blib(), $_ ) } qw( lib arch ) ),
          @INC
	);

	# this does
	local $ENV{HARNESS_PERL_SWITCHES} = '-Mblib';

	# actually run the tests, collecting diagnostics
	for my $file (@{ $self->SUPER( @_ ) })
	{
		my ($in, $out);

		my $pid     = open3( $in, $out, $out, $strap->_command_line( $file ));
		my %results = $strap->analyze_fh( $file, $out );

		if ($results{passing})
		{
			print $outfh "$file...ok\n" if $ENV{TEST_VERBOSE};
			next;
		}
		$self->save_failure_details( $file, \%results );
	}

	$self->report_failures();

	# don't let the tests leak out
	return [];
}

sub save_failure_details
{
	my ($self, $file, $results) = @_;
	my $failures                = $self->notes( 'test_failures' );

	my @failures;

	for my $number ( 1 .. @{ $results->{details} } )
	{
		my $test = $results->{details}[$number - 1];

		next if $test->{actual_ok};

		push @failures,
		{
			number      => $number,
			description => $test->{name}        || '',
			diagnostics => $test->{diagnostics} || '',
		};
	}

	delete $results->{details};
	$results->{file}     = $file;
	$results->{failures} = \@failures;
	push @$failures, $results;
}

sub report_failures
{
	my $self     = shift;
	my $failures = $self->notes( 'test_failures' );
	my $report   = '';

	for my $test ( @$failures )
	{
		my $failed  = $test->{seen} - $test->{ok};
		next unless $failed;

		$report    .= sprintf(
			"Test failures in '%s' (%d/%d):\n",
			$test->{file}, $failed, $test->{seen}
		);

		for my $failure (@{ $test->{failures} })
		{
			$report .= sprintf(
				"  %d: %s\n\t%s",
				@{$failure}{qw( number description diagnostics )}
			);
		}
	}

	return $self->write_success_results() unless $report;

	my $version_fh;

	my $version = "\n\n" .
		( open( $version_fh, $^X . ' -V |' ) ?
			join( '', <$version_fh> ) :
			"Could not find version information for $^X on $^O: $!\n" );

	$self->write_report( $report, $version );
	$self->write_failure_results( $report );
}

sub write_success_results
{
	my $self  = shift;
	my $oldfh = $self->notes( 'test_oldfh' );
	print $oldfh "All tests passed...\n";
}

sub write_report
{
	my ($self, $report, $version) = @_;
	my $file                      = $self->notes( 'report_file' );
	my $outfh                     = $self->notes( 'test_oldfh'  );

	open( my $out, '>', $file ) or die "Can't write $file: $!\n";
	print $out   $report, $version;
}

sub write_failure_results
{
	my ($self, $report) = @_;
	my $outfh           = $self->notes( 'test_oldfh'     );
	my $contact         = $self->notes( 'report_address' );
	my $report_file     = $self->notes( 'report_file'    );

	my $header          = "Tests failed!\n";
	$header .= "Please e-mail '$report_file' to $contact.\n" if $contact;

	print $outfh $header;
	print $outfh $report if $ENV{TEST_VERBOSE};
}

1;
__END__