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