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