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