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