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