lib/Test/Harness.pm

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