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     my($ret);
 327
 328     eval {require 'wait.ph'};
 329     if ($@) {
 330       SWITCH: {
 331             $ret = ($st & 0200); # Tim says, this is for 90%
 332         }
 333     } else {
 334         $ret = WCOREDUMP($st);
 335     }
 336
 337     eval { require Devel::CoreStack; $have_devel_corestack++ }
 338       unless $tried_devel_corestack++;
 339
 340     $ret;
 341 }
 342
 343 sub canonfailed ($@) {
 344     my($max,$skipped,@failed) = @_;
 345     my %seen;
 346     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
 347     my $failed = @failed;
 348     my @result = ();
 349     my @canon = ();
 350     my $min;
 351     my $last = $min = shift @failed;
 352     my $canon;
 353     if (@failed) {
 354         for (@failed, $failed[-1]) { # don't forget the last one
 355             if ($_ > $last+1 || $_ == $last) {
 356                 if ($min == $last) {
 357                     push @canon, $last;
 358                 } else {
 359                     push @canon, "$min-$last";
 360                 }
 361                 $min = $_;
 362             }
 363             $last = $_;
 364         }
 365         local $" = ", ";
 366         push @result, "FAILED tests @canon\n";
 367         $canon = "@canon";
 368     } else {
 369         push @result, "FAILED test $last\n";
 370         $canon = $last;
 371     }
 372
 373     push @result, "\tFailed $failed/$max tests, ";
 374     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay";
 375     my $ender = 's' x ($skipped > 1);
 376     my $good = $max - $failed - $skipped;
 377     my $goodper = sprintf("%.2f",100*($good/$max));
 378     push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped;
 379     push @result, "\n";
 380     my $txt = join "", @result;
 381     ($txt, $canon);
 382 }
 383
 384 1;
 385 __END__
 386
 387 =head1 NAME
 388
 389 Test::Harness - run perl standard test scripts with statistics
 390
 391 =head1 SYNOPSIS
 392
 393 use Test::Harness;
 394
 395 runtests(@tests);
 396
 397 =head1 DESCRIPTION
 398
 399 (By using the L<Test> module, you can write test scripts without
 400 knowing the exact output this module expects.  However, if you need to
 401 know the specifics, read on!)
 402
 403 Perl test scripts print to standard output C<"ok N"> for each single
 404 test, where C<N> is an increasing sequence of integers. The first line
 405 output by a standard test script is C<"1..M"> with C<M> being the
 406 number of tests that should be run within the test
 407 script. Test::Harness::runtests(@tests) runs all the testscripts
 408 named as arguments and checks standard output for the expected
 409 C<"ok N"> strings.
 410
 411 After all tests have been performed, runtests() prints some
 412 performance statistics that are computed by the Benchmark module.
 413
 414 =head2 The test script output
 415
 416 Any output from the testscript to standard error is ignored and
 417 bypassed, thus will be seen by the user. Lines written to standard
 418 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
 419 runtests().  All other lines are discarded.
 420
 421 It is tolerated if the test numbers after C<ok> are omitted. In this
 422 case Test::Harness maintains temporarily its own counter until the
 423 script supplies test numbers again. So the following test script
 424
 425     print <<END;
 426     1..6
 427     not ok
 428     ok
 429     not ok
 430     ok
 431     ok
 432     END
 433
 434 will generate
 435
 436     FAILED tests 1, 3, 6
 437     Failed 3/6 tests, 50.00% okay
 438
 439 The global variable $Test::Harness::verbose is exportable and can be
 440 used to let runtests() display the standard output of the script
 441 without altering the behavior otherwise.
 442
 443 The global variable $Test::Harness::switches is exportable and can be
 444 used to set perl command line options used for running the test
 445 script(s). The default value is C<-w>.
 446
 447 If the standard output line contains substring C< # Skip> (with
 448 variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
 449 counted as a skipped test.  If the whole testscript succeeds, the
 450 count of skipped tests is included in the generated output.
 451
 452 C<Test::Harness> reports the text after C< # Skip(whatever)> as a
 453 reason for skipping.  Similarly, one can include a similar explanation
 454 in a C<1..0> line emitted if the test is skipped completely:
 455
 456   1..0 # Skipped: no leverage found
 457
 458 =head1 EXPORT
 459
 460 C<&runtests> is exported by Test::Harness per default.
 461
 462 =head1 DIAGNOSTICS
 463
 464 =over 4
 465
 466 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 467
 468 If all tests are successful some statistics about the performance are
 469 printed.
 470
 471 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 472
 473 For any single script that has failing subtests statistics like the
 474 above are printed.
 475
 476 =item C<Test returned status %d (wstat %d)>
 477
 478 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
 479 printed in a message similar to the above.
 480
 481 =item C<Failed 1 test, %.2f%% okay. %s>
 482
 483 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 484
 485 If not all tests were successful, the script dies with one of the
 486 above messages.
 487
 488 =back
 489
 490 =head1 ENVIRONMENT
 491
 492 Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
 493 of child processes.
 494
 495 Setting C<HARNESS_NOTTY> to a true value forces it to behave as though
 496 STDOUT were not a console.  You may need to set this if you don't want
 497 harness to output more frequent progress messages using carriage returns.
 498 Some consoles may not handle carriage returns properly (which results
 499 in a somewhat messy output).
 500
 501 Setting C<HARNESS_COMPILE_TEST> to a true value will make harness attempt
 502 to compile the test using C<perlcc> before running it.
 503
 504 If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness
 505 will check after each test whether new files appeared in that directory,
 506 and report them as
 507
 508   LEAKED FILES: scr.tmp 0 my.db
 509
 510 If relative, directory name is with respect to the current directory at
 511 the moment runtests() was called.  Putting absolute path into
 512 C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
 513
 514 The value of C<HARNESS_PERL_SWITCHES> will be prepended to the
 515 switches used to invoke perl on each test.  For example, setting
 516 C<HARNESS_PERL_SWITCHES> to "-W" will run all tests with all
 517 warnings enabled.
 518
 519 Harness sets C<HARNESS_ACTIVE> before executing the individual tests.
 520 This allows the tests to determine if they are being executed through the
 521 harness or by any other means.
 522
 523 =head1 SEE ALSO
 524
 525 L<Test> for writing test scripts and also L<Benchmark> for the
 526 underlying timing routines.
 527
 528 =head1 AUTHORS
 529
 530 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 531 sure is, that it was inspired by Larry Wall's TEST script that came
 532 with perl distributions for ages. Numerous anonymous contributors
 533 exist. Current maintainer is Andreas Koenig.
 534
 535 =head1 BUGS
 536
 537 Test::Harness uses $^X to determine the perl binary to run the tests
 538 with. Test scripts running via the shebang (C<#!>) line may not be
 539 portable because $^X is not consistent for shebang scripts across
 540 platforms. This is no problem when Test::Harness is run with an
 541 absolute path to the perl binary or when $^X can be found in the path.
 542
 543 =cut