lib/Test/Harness.pm

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