lib/Test/Harness.pm

   1 package Test::Harness;
   2
   3 require 5.002;
   4
   5 use Exporter;
   6 use Benchmark;
   7 use Config;
   8 use FileHandle;
   9 use strict;
  10
  11 use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
  12             @ISA @EXPORT @EXPORT_OK);
  13 $have_devel_corestack = 0;
  14
  15 $VERSION = "1.13";
  16
  17 @ISA=('Exporter');
  18 @EXPORT= qw(&runtests);
  19 @EXPORT_OK= qw($verbose $switches);
  20
  21 format STDOUT_TOP =
  22 Failed Test  Status Wstat Total Fail  Failed  List of failed
  23 ------------------------------------------------------------------------------
  24 .
  25
  26 format STDOUT =
  27 @<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##%  @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  28 { $curtest->{name},
  29                 $curtest->{estat},
  30                     $curtest->{wstat},
  31                           $curtest->{max},
  32                                 $curtest->{failed},
  33                                      $curtest->{percent},
  34                                               $curtest->{canon}
  35 }
  36 .
  37
  38
  39 $verbose = 0;
  40 $switches = "-w";
  41
  42 sub runtests {
  43     my(@tests) = @_;
  44     local($|) = 1;
  45     my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests);
  46     my $totmax = 0;
  47     my $files = 0;
  48     my $bad = 0;
  49     my $good = 0;
  50     my $total = @tests;
  51
  52     # pass -I flags to children
  53     my $old5lib = $ENV{PERL5LIB};
  54     local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);
  55
  56     if ($Is_VMS) { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }
  57
  58     my $t_start = new Benchmark;
  59     while ($test = shift(@tests)) {
  60         $te = $test;
  61         chop($te);
  62         print "$te" . '.' x (20 - length($te));
  63         my $fh = new FileHandle;
  64         if ($^O eq 'VMS') { $fh->open("MCR $^X $switches $test|") || (print "can't run. $!\n"); }
  65         else              { $fh->open("$^X $switches $test|")     || (print "can't run. $!\n"); }
  66         $ok = $next = $max = 0;
  67         @failed = ();
  68         while (<$fh>) {
  69             if( $verbose ){
  70                 print $_;
  71             }
  72             if (/^1\.\.([0-9]+)/) {
  73                 $max = $1;
  74                 $totmax += $max;
  75                 $files++;
  76                 $next = 1;
  77             } elsif ($max && /^(not\s+)?ok\b/) {
  78                 my $this = $next;
  79                 if (/^not ok\s*(\d*)/){
  80                     $this = $1 if $1 > 0;
  81                     push @failed, $this;
  82                 } elsif (/^ok\s*(\d*)/) {
  83                     $this = $1 if $1 > 0;
  84                     $ok++;
  85                     $totok++;
  86                 }
  87                 if ($this > $next) {
  88                     # warn "Test output counter mismatch [test $this]\n";
  89                     # no need to warn probably
  90                     push @failed, $next..$this-1;
  91                 } elsif ($this < $next) {
  92                     #we have seen more "ok" lines than the number suggests
  93                     warn "Confused test output: test $this answered after test ", $next-1, "\n";
  94                     $next = $this;
  95                 }
  96                 $next = $this + 1;
  97             }
  98         }
  99         $fh->close; # must close to reap child resource values
 100         my $wstatus = $?;
 101         my $estatus = $^O eq 'VMS' ? $wstatus : $wstatus >> 8;
 102         if ($^O eq 'VMS' ? !($wstatus & 1) : $wstatus) {
 103             print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n";
 104             if (corestatus($wstatus)) { # until we have a wait module
 105                 if ($have_devel_corestack) {
 106                     Devel::CoreStack::stack($^X);
 107                 } else {
 108                     print "\ttest program seems to have generated a core\n";
 109                 }
 110             }
 111             $bad++;
 112             $failedtests{$test} = { canon => '??',  max => $max || '??',
 113                                     failed => '??',
 114                                     name => $test, percent => undef,
 115                                     estat => $estatus, wstat => $wstatus,
 116                                   };
 117         } elsif ($ok == $max && $next == $max+1) {
 118             if ($max) {
 119                 print "ok\n";
 120             } else {
 121                 print "skipping test on this platform\n";
 122             }
 123             $good++;
 124         } elsif ($max) {
 125             if ($next <= $max) {
 126                 push @failed, $next..$max;
 127             }
 128             if (@failed) {
 129                 my ($txt, $canon) = canonfailed($max,@failed);
 130                 print $txt;
 131                 $failedtests{$test} = { canon => $canon,  max => $max,
 132                                         failed => scalar @failed,
 133                                         name => $test, percent => 100*(scalar @failed)/$max,
 134                                         estat => '', wstat => '',
 135                                       };
 136             } else {
 137                 print "Don't know which tests failed: got $ok ok, expected $max\n";
 138                 $failedtests{$test} = { canon => '??',  max => $max,
 139                                         failed => '??',
 140                                         name => $test, percent => undef,
 141                                         estat => '', wstat => '',
 142                                       };
 143             }
 144             $bad++;
 145         } elsif ($next == 0) {
 146             print "FAILED before any test output arrived\n";
 147             $bad++;
 148             $failedtests{$test} = { canon => '??',  max => '??',
 149                                     failed => '??',
 150                                     name => $test, percent => undef,
 151                                     estat => '', wstat => '',
 152                                   };
 153         }
 154     }
 155     my $t_total = timediff(new Benchmark, $t_start);
 156
 157     if ($^O eq 'VMS') {
 158         if (defined $old5lib) {
 159             $ENV{PERL5LIB} = $old5lib;
 160         }
 161         else {
 162             delete $ENV{PERL5LIB};
 163         }
 164     }
 165     if ($bad == 0 && $totmax) {
 166             print "All tests successful.\n";
 167     } elsif ($total==0){
 168         die "FAILED--no tests were run for some reason.\n";
 169     } elsif ($totmax==0) {
 170         my $blurb = $total==1 ? "script" : "scripts";
 171         die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
 172     } else {
 173         $pct = sprintf("%.2f", $good / $total * 100);
 174         my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
 175         $totmax - $totok, $totmax, 100*$totok/$totmax;
 176         my $script;
 177         for $script (sort keys %failedtests) {
 178           $curtest = $failedtests{$script};
 179           write;
 180         }
 181         if ($bad > 1) {
 182             die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
 183         }
 184     }
 185     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
 186
 187     return ($bad == 0 && $totmax) ;
 188 }
 189
 190 sub corestatus {
 191     my($st) = @_;
 192     my($ret);
 193
 194     eval {require 'wait.ph'};
 195     if ($@) {
 196       SWITCH: {
 197             $ret = ($st & 0200); # Tim says, this is for 90%
 198         }
 199     } else {
 200         $ret = WCOREDUMP($st);
 201     }
 202
 203     eval {require Devel::CoreStack};
 204     $have_devel_corestack++ unless $@;
 205
 206     $ret;
 207 }
 208
 209 sub canonfailed ($@) {
 210     my($max,@failed) = @_;
 211     my %seen;
 212     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
 213     my $failed = @failed;
 214     my @result = ();
 215     my @canon = ();
 216     my $min;
 217     my $last = $min = shift @failed;
 218     my $canon;
 219     if (@failed) {
 220         for (@failed, $failed[-1]) { # don't forget the last one
 221             if ($_ > $last+1 || $_ == $last) {
 222                 if ($min == $last) {
 223                     push @canon, $last;
 224                 } else {
 225                     push @canon, "$min-$last";
 226                 }
 227                 $min = $_;
 228             }
 229             $last = $_;
 230         }
 231         local $" = ", ";
 232         push @result, "FAILED tests @canon\n";
 233         $canon = "@canon";
 234     } else {
 235         push @result, "FAILED test $last\n";
 236         $canon = $last;
 237     }
 238
 239     push @result, "\tFailed $failed/$max tests, ";
 240     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
 241     my $txt = join "", @result;
 242     ($txt, $canon);
 243 }
 244
 245 1;
 246 __END__
 247
 248 =head1 NAME
 249
 250 Test::Harness - run perl standard test scripts with statistics
 251
 252 =head1 SYNOPSIS
 253
 254 use Test::Harness;
 255
 256 runtests(@tests);
 257
 258 =head1 DESCRIPTION
 259
 260 Perl test scripts print to standard output C<"ok N"> for each single
 261 test, where C<N> is an increasing sequence of integers. The first line
 262 output by a standard test script is C<"1..M"> with C<M> being the
 263 number of tests that should be run within the test
 264 script. Test::Harness::runtests(@tests) runs all the testscripts
 265 named as arguments and checks standard output for the expected
 266 C<"ok N"> strings.
 267
 268 After all tests have been performed, runtests() prints some
 269 performance statistics that are computed by the Benchmark module.
 270
 271 =head2 The test script output
 272
 273 Any output from the testscript to standard error is ignored and
 274 bypassed, thus will be seen by the user. Lines written to standard
 275 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
 276 runtests().  All other lines are discarded.
 277
 278 It is tolerated if the test numbers after C<ok> are omitted. In this
 279 case Test::Harness maintains temporarily its own counter until the
 280 script supplies test numbers again. So the following test script
 281
 282     print <<END;
 283     1..6
 284     not ok
 285     ok
 286     not ok
 287     ok
 288     ok
 289     END
 290
 291 will generate
 292
 293     FAILED tests 1, 3, 6
 294     Failed 3/6 tests, 50.00% okay
 295
 296 The global variable $Test::Harness::verbose is exportable and can be
 297 used to let runtests() display the standard output of the script
 298 without altering the behavior otherwise.
 299
 300 =head1 EXPORT
 301
 302 C<&runtests> is exported by Test::Harness per default.
 303
 304 =head1 DIAGNOSTICS
 305
 306 =over 4
 307
 308 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 309
 310 If all tests are successful some statistics about the performance are
 311 printed.
 312
 313 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 314
 315 For any single script that has failing subtests statistics like the
 316 above are printed.
 317
 318 =item C<Test returned status %d (wstat %d)>
 319
 320 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
 321 printed in a message similar to the above.
 322
 323 =item C<Failed 1 test, %.2f%% okay. %s>
 324
 325 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 326
 327 If not all tests were successful, the script dies with one of the
 328 above messages.
 329
 330 =back
 331
 332 =head1 SEE ALSO
 333
 334 See L<Benchmark> for the underlying timing routines.
 335
 336 =head1 AUTHORS
 337
 338 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 339 sure is, that it was inspired by Larry Wall's TEST script that came
 340 with perl distributions for ages. Current maintainer is Andreas
 341 Koenig.
 342
 343 =head1 BUGS
 344
 345 Test::Harness uses $^X to determine the perl binary to run the tests
 346 with. Test scripts running via the shebang (C<#!>) line may not be
 347 portable because $^X is not consistent for shebang scripts across
 348 platforms. This is no problem when Test::Harness is run with an
 349 absolute path to the perl binary or when $^X can be found in the path.
 350
 351 =cut