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