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