File Coverage

blib/lib/PANT/Test.pm

Criterion	Covered	Total	%
statement	78	116	67.2
branch	9	34	26.4
condition			n/a
subroutine	11	12	91.6
pod	1	3	33.3
total	99	165	60.0

# PANT::Test - Test modules from PANT

package PANT::Test;

use 5.008;
use strict;
use warnings;
use Carp;
use Cwd;
use XML::Writer;
use Test::Harness::Straps;
use Benchmark;
use Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use PANT ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw() ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw( );

our $VERSION = '0.15';


sub new {
    my($clsname, $writer, @args) =@_;
    my $self = {
	writer=>$writer,
	@args
    };
    bless $self, $clsname;
    return $self;
}

sub RunTests {
    my($self, %args) = @_;
    my $writer = $self->{writer};
    my $dir = $args{directory};
    my $pushstreams = 1;
    my $cdir;
    if ($dir) {
	$cdir = getcwd;
	chdir($dir) || Abort("Can't change to directory $dir");
    }
    my $retval = 1;
    $writer->dataElement('h2', "Run the following tests");
    $writer->startTag('ul');
    $writer->startTag('table', border=>1);
    $writer->startTag('tr');
    foreach my $h (("Test",  "No.", "Passed", "Failed", "Skipped", "Pass rate", "Failure reason")) {
      $writer->dataElement('th', $h);
    }
    $writer->endTag('tr');
    my $stderrfile = "xxxxstderr$$.txt";
    my($OLDERR, $stderr);
    if ($pushstreams) {
      # push the output state
      open $OLDERR,     ">&", \*STDERR or die "Can't dup STDERR: $!";
      $stderr = "";
      close(STDERR);
      open(STDERR, ">$stderrfile")      or die "Can't open STDERR: $!";
    }
    my $totaltests = 0;
    my $totalpass = 0;
    my $tfiles = 0;
    my $tfailures = 0;
    my $strap = new Test::Harness::Straps;
    my $t_start = new Benchmark;

    foreach my $tfile (@{$args{tests}}) {
      $writer->startTag('tr');
      $writer->dataElement('td', $tfile);
      $tfiles ++;

      my %results;
      if (!$self->{dryrun}) {
	%results = $strap->analyze_file($tfile);
      }

      if (!%results) {
	$writer->dataElement('td', $self->{dryrun} ? "Test not run -dryrun" : $strap->{error});
	$writer->endTag('tr');
	$totaltests ++;
	next;
      };
      $tfailures ++ if (!$results{passing});
      $totalpass +=  $results{ok};
      $totaltests += $results{max};
      my %attr = (id=> ($results{passing} ? "pass" : "fail"));
      $writer->dataElement('td',  $results{max}, %attr);
      $writer->dataElement('td', $results{ok}, %attr);
      $writer->dataElement('td',  $results{max} - $results{ok}, %attr);
      $writer->dataElement('td', $results{skip}, %attr);
      $writer->dataElement('td', sprintf("%.2f", $results{ok} / $results{max} * 100), %attr);
      $writer->startTag('td', %attr);
      foreach my $err (MakeFailureReport(\%results)) {
	$writer->characters($err);
	$writer->emptyTag('br');
      }
      $writer->endTag('td');
      $writer->endTag('tr');
    }
    my $timed = timediff(new Benchmark, $t_start);
    if ($pushstreams) {
      open STDERR, ">&", $OLDERR    or die "Can't dup OLDERR: $!";
      if (open JUNK, "$stderrfile") {
	  local($/);
	  $stderr = ;
	  close(JUNK);
      }
      unlink($stderrfile);
    }
    $writer->endTag("table");
    $writer->dataElement('li',
			 sprintf("Summary: Test Files $tfiles, Failed Test files $tfailures, %.2f%%",
				 ($tfiles-$tfailures) / $tfiles * 100));
    $writer->dataElement('li',
			 sprintf("Summary: Total Tests $totaltests, Failed Tests %d, Pass rate %.2f%%",
				 $totaltests - $totalpass,
				 $totalpass / $totaltests * 100));
    $writer->dataElement('li', "Took " . timestr($timed));

    if($stderr) {
      $writer->dataElement('li', "Error output");
      $writer->dataElement('pre', $stderr);
    }
    chdir ($cdir) if ($cdir);
    $writer->endTag('ul');
    return $retval;
}

sub MakeFailureReport {
  my $report = shift;
  return ("All Passed") if ($report->{passing});
  my @results = ();
  my $tnum = 0;
  foreach my $test (@{$report->{details}}) {
    $tnum ++;
    next if ($test->{ok});
    push(@results, "$tnum $test->{name}");
  }
  return @results;
}
1;
__END__