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