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