lib/Test/Harness.pm

   1 package Test::Harness;
   2
   3 use Exporter;
   4 use Benchmark;
   5 use Config;
   6 require 5.002;
   7
   8 $VERSION = $VERSION = "1.02";
   9
  10 @ISA=('Exporter');
  11 @EXPORT= qw(&runtests);
  12 @EXPORT_OK= qw($verbose $switches);
  13
  14
  15 $Test::Harness::verbose = 0;
  16 $Test::Harness::switches = "-w";
  17
  18 sub runtests {
  19     my(@tests) = @_;
  20     local($|) = 1;
  21     my($test,$te,$ok,$next,$max,$totmax, $files,$pct,@failed);
  22     my $bad = 0;
  23     my $good = 0;
  24     my $total = @tests;
  25     local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
  26
  27     my $t_start = new Benchmark;
  28     while ($test = shift(@tests)) {
  29         $te = $test;
  30         chop($te);
  31         print "$te" . '.' x (20 - length($te));
  32         my $fh = "RESULTS";
  33         open($fh,"$^X $Test::Harness::switches $test|") || (print "can't run. $!\n");
  34         $ok = $next = $max = 0;
  35         @failed = ();
  36         while (<$fh>) {
  37             if( $Test::Harness::verbose ){
  38                 print $_;
  39             }
  40             unless (/^\#/) {
  41                 if (/^1\.\.([0-9]+)/) {
  42                     $max = $1;
  43                     $totmax += $max;
  44                     $files++;
  45                     $next = 1;
  46                 } elsif ($max) {
  47                     if (/^not ok ([0-9]*)/){
  48                         push @failed, $next;
  49                     } elsif (/^ok (.*)/ && $1 == $next) {
  50                         $ok++;
  51                     }
  52                     $next = $1 + 1;
  53                 }
  54             }
  55         }
  56         close($fh); # must close to reap child resource values
  57         my $wstatus = $?;
  58         my $estatus = $wstatus >> 8;
  59         $next-- if $next;
  60         if ($ok == $max && $next == $max && ! $wstatus) {
  61             print "ok\n";
  62             $good++;
  63         } else {
  64             if (@failed) {
  65                 print canonfailed($max,@failed);
  66             } else {
  67                 if ($next == 0) {
  68                     print "FAILED before any test output arrived\n";
  69                 } else {
  70                     print canonfailed($max,$next+1..$max);
  71                 }
  72             }
  73             if ($wstatus) {
  74                 print "\tTest returned status $estatus (wstat $wstatus)\n";
  75             }
  76             $bad++;
  77             $_ = $test;
  78         }
  79     }
  80     my $t_total = timediff(new Benchmark, $t_start);
  81
  82     if ($bad == 0) {
  83         if ($ok) {
  84             print "All tests successful.\n";
  85         } else {
  86             die "FAILED--no tests were run for some reason.\n";
  87         }
  88     } else {
  89         $pct = sprintf("%.2f", $good / $total * 100);
  90         if ($bad == 1) {
  91             die "Failed 1 test script, $pct% okay.\n";
  92         } else {
  93             die "Failed $bad/$total test scripts, $pct% okay.\n";
  94         }
  95     }
  96     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
  97 }
  98
  99 sub canonfailed ($@) {
 100     my($max,@failed) = @_;
 101     my $failed = @failed;
 102     my @result = ();
 103     my @canon = ();
 104     my $min;
 105     my $last = $min = shift @failed;
 106     if (@failed) {
 107         for (@failed, $failed[-1]) { # don't forget the last one
 108             if ($_ > $last+1 || $_ == $last) {
 109                 if ($min == $last) {
 110                     push @canon, $last;
 111                 } else {
 112                     push @canon, "$min-$last";
 113                 }
 114                 $min = $_;
 115             }
 116             $last = $_;
 117         }
 118         local $" = ", ";
 119         push @result, "FAILED tests @canon\n";
 120     } else {
 121         push @result, "FAILED test $last\n";
 122     }
 123
 124     push @result, "\tFailed $failed/$max tests, ";
 125     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
 126     join "", @result;
 127 }
 128
 129 1;
 130 __END__
 131
 132 =head1 NAME
 133
 134 Test::Harness - run perl standard test scripts with statistics
 135
 136 =head1 SYNOPSIS
 137
 138 use Test::Harness;
 139
 140 runtests(@tests);
 141
 142 =head1 DESCRIPTION
 143
 144 Perl test scripts print to standard output C<"ok N"> for each single
 145 test, where C<N> is an increasing sequence of integers. The first line
 146 output by a standard test scxript is C<"1..M"> with C<M> being the
 147 number of tests that should be run within the test
 148 script. Test::Harness::runscripts(@tests) runs all the testscripts
 149 named as arguments and checks standard output for the expected
 150 C<"ok N"> strings.
 151
 152 After all tests have been performed, runscripts() prints some
 153 performance statistics that are computed by the Benchmark module.
 154
 155 =head1 EXPORT
 156
 157 C<&runscripts> is exported by Test::Harness per default.
 158
 159 =head1 DIAGNOSTICS
 160
 161 =over 4
 162
 163 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 164
 165 If all tests are successful some statistics about the performance are
 166 printed.
 167
 168 =item C<Failed 1 test, $pct% okay.>
 169
 170 =item C<Failed %d/%d tests, %.2f%% okay.>
 171
 172 If not all tests were successful, the script dies with one of the
 173 above messages.
 174
 175 =back
 176
 177 =head1 SEE ALSO
 178
 179 See L<Benchmark> for the underlying timing routines.
 180
 181 =head1 AUTHORS
 182
 183 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 184 sure is, that it was inspired by Larry Wall's TEST script that came
 185 with perl distributions for ages. Current maintainer is Andreas
 186 Koenig.
 187
 188 =head1 BUGS
 189
 190 Test::Harness uses $^X to determine the perl binary to run the tests
 191 with. Test scripts running via the shebang (C<#!>) line may not be portable
 192 because $^X is not consistent for shebang scripts across
 193 platforms. This is no problem when Test::Harness is run with an
 194 absolute path to the perl binary.
 195
 196 =cut