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