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