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