lib/Test/Harness.pm

   1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2
   3 package Test::Harness;
   4
   5 require 5.00405;
   6 use Test::Harness::Straps;
   7 use Test::Harness::Assert;
   8 use Exporter;
   9 use Benchmark;
  10 use Config;
  11 use strict;
  12
  13 use vars qw(
  14     $VERSION
  15     @ISA @EXPORT @EXPORT_OK
  16     $Verbose $Switches $Debug
  17     $verbose $switches $debug
  18     $Curtest
  19     $Columns
  20     $ML $Last_ML_Print
  21     $Strap
  22 );
  23
  24 =head1 NAME
  25
  26 Test::Harness - Run Perl standard test scripts with statistics
  27
  28 =head1 VERSION
  29
  30 Version 2.48
  31
  32 =cut
  33
  34 $VERSION = "2.48";
  35
  36 # Backwards compatibility for exportable variable names.
  37 *verbose  = *Verbose;
  38 *switches = *Switches;
  39 *debug    = *Debug;
  40
  41 $ENV{HARNESS_ACTIVE} = 1;
  42 $ENV{HARNESS_VERSION} = $VERSION;
  43
  44 END {
  45     # For VMS.
  46     delete $ENV{HARNESS_ACTIVE};
  47     delete $ENV{HARNESS_VERSION};
  48 }
  49
  50 # Some experimental versions of OS/2 build have broken $?
  51 my $Ignore_Exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
  52
  53 my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
  54
  55 $Strap = Test::Harness::Straps->new;
  56
  57 sub strap { return $Strap };
  58
  59 @ISA = ('Exporter');
  60 @EXPORT    = qw(&runtests);
  61 @EXPORT_OK = qw($verbose $switches);
  62
  63 $Verbose  = $ENV{HARNESS_VERBOSE} || 0;
  64 $Debug    = $ENV{HARNESS_DEBUG} || 0;
  65 $Switches = "-w";
  66 $Columns  = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
  67 $Columns--;             # Some shells have trouble with a full line of text.
  68
  69 =head1 SYNOPSIS
  70
  71   use Test::Harness;
  72
  73   runtests(@test_files);
  74
  75 =head1 DESCRIPTION
  76
  77 B<STOP!> If all you want to do is write a test script, consider
  78 using Test::Simple.  Test::Harness is the module that reads the
  79 output from Test::Simple, Test::More and other modules based on
  80 Test::Builder.  You don't need to know about Test::Harness to use
  81 those modules.
  82
  83 Test::Harness runs tests and expects output from the test in a
  84 certain format.  That format is called TAP, the Test Anything
  85 Protocol.  It is defined in L<Test::Harness::TAP>.
  86
  87 C<Test::Harness::runtests(@tests)> runs all the testscripts named
  88 as arguments and checks standard output for the expected strings
  89 in TAP format.
  90
  91 The F<prove> utility is a thin wrapper around Test::Harness.
  92
  93 =head2 Taint mode
  94
  95 Test::Harness will honor the C<-T> or C<-t> in the #! line on your
  96 test files.  So if you begin a test with:
  97
  98     #!perl -T
  99
 100 the test will be run with taint mode on.
 101
 102 =head2 Configuration variables.
 103
 104 These variables can be used to configure the behavior of
 105 Test::Harness.  They are exported on request.
 106
 107 =over 4
 108
 109 =item C<$Test::Harness::Verbose>
 110
 111 The package variable C<$Test::Harness::Verbose> is exportable and can be
 112 used to let C<runtests()> display the standard output of the script
 113 without altering the behavior otherwise.  The F<prove> utility's C<-v>
 114 flag will set this.
 115
 116 =item C<$Test::Harness::switches>
 117
 118 The package variable C<$Test::Harness::switches> is exportable and can be
 119 used to set perl command line options used for running the test
 120 script(s). The default value is C<-w>. It overrides C<HARNESS_SWITCHES>.
 121
 122 =back
 123
 124
 125 =head2 Failure
 126
 127 When tests fail, analyze the summary report:
 128
 129   t/base..............ok
 130   t/nonumbers.........ok
 131   t/ok................ok
 132   t/test-harness......ok
 133   t/waterloo..........dubious
 134           Test returned status 3 (wstat 768, 0x300)
 135   DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19
 136           Failed 10/20 tests, 50.00% okay
 137   Failed Test  Stat Wstat Total Fail  Failed  List of Failed
 138   -----------------------------------------------------------------------
 139   t/waterloo.t    3   768    20   10  50.00%  1 3 5 7 9 11 13 15 17 19
 140   Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay.
 141
 142 Everything passed but F<t/waterloo.t>.  It failed 10 of 20 tests and
 143 exited with non-zero status indicating something dubious happened.
 144
 145 The columns in the summary report mean:
 146
 147 =over 4
 148
 149 =item B<Failed Test>
 150
 151 The test file which failed.
 152
 153 =item B<Stat>
 154
 155 If the test exited with non-zero, this is its exit status.
 156
 157 =item B<Wstat>
 158
 159 The wait status of the test.
 160
 161 =item B<Total>
 162
 163 Total number of tests expected to run.
 164
 165 =item B<Fail>
 166
 167 Number which failed, either from "not ok" or because they never ran.
 168
 169 =item B<Failed>
 170
 171 Percentage of the total tests which failed.
 172
 173 =item B<List of Failed>
 174
 175 A list of the tests which failed.  Successive failures may be
 176 abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and
 177 20 failed).
 178
 179 =back
 180
 181
 182 =head2 Functions
 183
 184 Test::Harness currently only has one function, here it is.
 185
 186 =over 4
 187
 188 =item B<runtests>
 189
 190   my $allok = runtests(@test_files);
 191
 192 This runs all the given I<@test_files> and divines whether they passed
 193 or failed based on their output to STDOUT (details above).  It prints
 194 out each individual test which failed along with a summary report and
 195 a how long it all took.
 196
 197 It returns true if everything was ok.  Otherwise it will C<die()> with
 198 one of the messages in the DIAGNOSTICS section.
 199
 200 =cut
 201
 202 sub runtests {
 203     my(@tests) = @_;
 204
 205     local ($\, $,);
 206
 207     my($tot, $failedtests) = _run_all_tests(@tests);
 208     _show_results($tot, $failedtests);
 209
 210     my $ok = _all_ok($tot);
 211
 212     assert(($ok xor keys %$failedtests),
 213            q{ok status jives with $failedtests});
 214
 215     return $ok;
 216 }
 217
 218 =begin _private
 219
 220 =item B<_all_ok>
 221
 222   my $ok = _all_ok(\%tot);
 223
 224 Tells you if this test run is overall successful or not.
 225
 226 =cut
 227
 228 sub _all_ok {
 229     my($tot) = shift;
 230
 231     return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0;
 232 }
 233
 234 =item B<_globdir>
 235
 236   my @files = _globdir $dir;
 237
 238 Returns all the files in a directory.  This is shorthand for backwards
 239 compatibility on systems where C<glob()> doesn't work right.
 240
 241 =cut
 242
 243 sub _globdir {
 244     opendir DIRH, shift;
 245     my @f = readdir DIRH;
 246     closedir DIRH;
 247
 248     return @f;
 249 }
 250
 251 =item B<_run_all_tests>
 252
 253   my($total, $failed) = _run_all_tests(@test_files);
 254
 255 Runs all the given C<@test_files> (as C<runtests()>) but does it
 256 quietly (no report).  $total is a hash ref summary of all the tests
 257 run.  Its keys and values are this:
 258
 259     bonus           Number of individual todo tests unexpectedly passed
 260     max             Number of individual tests ran
 261     ok              Number of individual tests passed
 262     sub_skipped     Number of individual tests skipped
 263     todo            Number of individual todo tests
 264
 265     files           Number of test files ran
 266     good            Number of test files passed
 267     bad             Number of test files failed
 268     tests           Number of test files originally given
 269     skipped         Number of test files skipped
 270
 271 If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
 272 got a successful test.
 273
 274 $failed is a hash ref of all the test scripts which failed.  Each key
 275 is the name of a test script, each value is another hash representing
 276 how that script failed.  Its keys are these:
 277
 278     name        Name of the test which failed
 279     estat       Script's exit value
 280     wstat       Script's wait status
 281     max         Number of individual tests
 282     failed      Number which failed
 283     percent     Percentage of tests which failed
 284     canon       List of tests which failed (as string).
 285
 286 C<$failed> should be empty if everything passed.
 287
 288 B<NOTE> Currently this function is still noisy.  I'm working on it.
 289
 290 =cut
 291
 292 # Turns on autoflush for the handle passed
 293 sub _autoflush {
 294     my $flushy_fh = shift;
 295     my $old_fh = select $flushy_fh;
 296     $| = 1;
 297     select $old_fh;
 298 }
 299
 300 sub _run_all_tests {
 301     my @tests = @_;
 302
 303     _autoflush(\*STDOUT);
 304     _autoflush(\*STDERR);
 305
 306     my(%failedtests);
 307
 308     # Test-wide totals.
 309     my(%tot) = (
 310                 bonus    => 0,
 311                 max      => 0,
 312                 ok       => 0,
 313                 files    => 0,
 314                 bad      => 0,
 315                 good     => 0,
 316                 tests    => scalar @tests,
 317                 sub_skipped  => 0,
 318                 todo     => 0,
 319                 skipped  => 0,
 320                 bench    => 0,
 321                );
 322
 323     my @dir_files;
 324     @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
 325     my $t_start = new Benchmark;
 326
 327     my $width = _leader_width(@tests);
 328     foreach my $tfile (@tests) {
 329         $Last_ML_Print = 0;  # so each test prints at least once
 330         my($leader, $ml) = _mk_leader($tfile, $width);
 331         local $ML = $ml;
 332
 333         print $leader;
 334
 335         $tot{files}++;
 336
 337         $Strap->{_seen_header} = 0;
 338         if ( $Test::Harness::Debug ) {
 339             print "# Running: ", $Strap->_command_line($tfile), "\n";
 340         }
 341         my %results = $Strap->analyze_file($tfile) or
 342           do { warn $Strap->{error}, "\n";  next };
 343
 344         # state of the current test.
 345         my @failed = grep { !$results{details}[$_-1]{ok} }
 346                      1..@{$results{details}};
 347         my %test = (
 348                     ok          => $results{ok},
 349                     'next'      => $Strap->{'next'},
 350                     max         => $results{max},
 351                     failed      => \@failed,
 352                     bonus       => $results{bonus},
 353                     skipped     => $results{skip},
 354                     skip_reason => $results{skip_reason},
 355                     skip_all    => $Strap->{skip_all},
 356                     ml          => $ml,
 357                    );
 358
 359         $tot{bonus}       += $results{bonus};
 360         $tot{max}         += $results{max};
 361         $tot{ok}          += $results{ok};
 362         $tot{todo}        += $results{todo};
 363         $tot{sub_skipped} += $results{skip};
 364
 365         my($estatus, $wstatus) = @results{qw(exit wait)};
 366
 367         if ($results{passing}) {
 368             if ($test{max} and $test{skipped} + $test{bonus}) {
 369                 my @msg;
 370                 push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
 371                     if $test{skipped};
 372                 push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
 373                     if $test{bonus};
 374                 print "$test{ml}ok\n        ".join(', ', @msg)."\n";
 375             } elsif ($test{max}) {
 376                 print "$test{ml}ok\n";
 377             } elsif (defined $test{skip_all} and length $test{skip_all}) {
 378                 print "skipped\n        all skipped: $test{skip_all}\n";
 379                 $tot{skipped}++;
 380             } else {
 381                 print "skipped\n        all skipped: no reason given\n";
 382                 $tot{skipped}++;
 383             }
 384             $tot{good}++;
 385         }
 386         else {
 387             # List unrun tests as failures.
 388             if ($test{'next'} <= $test{max}) {
 389                 push @{$test{failed}}, $test{'next'}..$test{max};
 390             }
 391             # List overruns as failures.
 392             else {
 393                 my $details = $results{details};
 394                 foreach my $overrun ($test{max}+1..@$details) {
 395                     next unless ref $details->[$overrun-1];
 396                     push @{$test{failed}}, $overrun
 397                 }
 398             }
 399
 400             if ($wstatus) {
 401                 $failedtests{$tfile} = _dubious_return(\%test, \%tot,
 402                                                        $estatus, $wstatus);
 403                 $failedtests{$tfile}{name} = $tfile;
 404             }
 405             elsif($results{seen}) {
 406                 if (@{$test{failed}} and $test{max}) {
 407                     my ($txt, $canon) = _canonfailed($test{max},$test{skipped},
 408                                                     @{$test{failed}});
 409                     print "$test{ml}$txt";
 410                     $failedtests{$tfile} = { canon   => $canon,
 411                                              max     => $test{max},
 412                                              failed  => scalar @{$test{failed}},
 413                                              name    => $tfile,
 414                                              percent => 100*(scalar @{$test{failed}})/$test{max},
 415                                              estat   => '',
 416                                              wstat   => '',
 417                                            };
 418                 } else {
 419                     print "Don't know which tests failed: got $test{ok} ok, ".
 420                           "expected $test{max}\n";
 421                     $failedtests{$tfile} = { canon   => '??',
 422                                              max     => $test{max},
 423                                              failed  => '??',
 424                                              name    => $tfile,
 425                                              percent => undef,
 426                                              estat   => '',
 427                                              wstat   => '',
 428                                            };
 429                 }
 430                 $tot{bad}++;
 431             } else {
 432                 print "FAILED before any test output arrived\n";
 433                 $tot{bad}++;
 434                 $failedtests{$tfile} = { canon       => '??',
 435                                          max         => '??',
 436                                          failed      => '??',
 437                                          name        => $tfile,
 438                                          percent     => undef,
 439                                          estat       => '',
 440                                          wstat       => '',
 441                                        };
 442             }
 443         }
 444
 445         if (defined $Files_In_Dir) {
 446             my @new_dir_files = _globdir $Files_In_Dir;
 447             if (@new_dir_files != @dir_files) {
 448                 my %f;
 449                 @f{@new_dir_files} = (1) x @new_dir_files;
 450                 delete @f{@dir_files};
 451                 my @f = sort keys %f;
 452                 print "LEAKED FILES: @f\n";
 453                 @dir_files = @new_dir_files;
 454             }
 455         }
 456     } # foreach test
 457     $tot{bench} = timediff(new Benchmark, $t_start);
 458
 459     $Strap->_restore_PERL5LIB;
 460
 461     return(\%tot, \%failedtests);
 462 }
 463
 464 =item B<_mk_leader>
 465
 466   my($leader, $ml) = _mk_leader($test_file, $width);
 467
 468 Generates the 't/foo........' leader for the given C<$test_file> as well
 469 as a similar version which will overwrite the current line (by use of
 470 \r and such).  C<$ml> may be empty if Test::Harness doesn't think you're
 471 on TTY.
 472
 473 The C<$width> is the width of the "yada/blah.." string.
 474
 475 =cut
 476
 477 sub _mk_leader {
 478     my($te, $width) = @_;
 479     chomp($te);
 480     $te =~ s/\.\w+$/./;
 481
 482     if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; }
 483     my $blank = (' ' x 77);
 484     my $leader = "$te" . '.' x ($width - length($te));
 485     my $ml = "";
 486
 487     $ml = "\r$blank\r$leader"
 488       if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
 489
 490     return($leader, $ml);
 491 }
 492
 493 =item B<_leader_width>
 494
 495   my($width) = _leader_width(@test_files);
 496
 497 Calculates how wide the leader should be based on the length of the
 498 longest test name.
 499
 500 =cut
 501
 502 sub _leader_width {
 503     my $maxlen = 0;
 504     my $maxsuflen = 0;
 505     foreach (@_) {
 506         my $suf    = /\.(\w+)$/ ? $1 : '';
 507         my $len    = length;
 508         my $suflen = length $suf;
 509         $maxlen    = $len    if $len    > $maxlen;
 510         $maxsuflen = $suflen if $suflen > $maxsuflen;
 511     }
 512     # + 3 : we want three dots between the test name and the "ok"
 513     return $maxlen + 3 - $maxsuflen;
 514 }
 515
 516
 517 sub _show_results {
 518     my($tot, $failedtests) = @_;
 519
 520     my $pct;
 521     my $bonusmsg = _bonusmsg($tot);
 522
 523     if (_all_ok($tot)) {
 524         print "All tests successful$bonusmsg.\n";
 525     } elsif (!$tot->{tests}){
 526         die "FAILED--no tests were run for some reason.\n";
 527     } elsif (!$tot->{max}) {
 528         my $blurb = $tot->{tests}==1 ? "script" : "scripts";
 529         die "FAILED--$tot->{tests} test $blurb could be run, ".
 530             "alas--no output ever seen\n";
 531     } else {
 532         $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
 533         my $percent_ok = 100*$tot->{ok}/$tot->{max};
 534         my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
 535                               $tot->{max} - $tot->{ok}, $tot->{max},
 536                               $percent_ok;
 537
 538         my($fmt_top, $fmt) = _create_fmts($failedtests);
 539
 540         # Now write to formats
 541         for my $script (sort keys %$failedtests) {
 542           $Curtest = $failedtests->{$script};
 543           write;
 544         }
 545         if ($tot->{bad}) {
 546             $bonusmsg =~ s/^,\s*//;
 547             print "$bonusmsg.\n" if $bonusmsg;
 548             die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
 549                 "$subpct\n";
 550         }
 551     }
 552
 553     printf("Files=%d, Tests=%d, %s\n",
 554            $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
 555 }
 556
 557
 558 my %Handlers = (
 559     header => \&header_handler,
 560     test => \&test_handler,
 561     bailout => \&bailout_handler,
 562 );
 563
 564 $Strap->{callback} = \&strap_callback;
 565 sub strap_callback {
 566     my($self, $line, $type, $totals) = @_;
 567     print $line if $Verbose;
 568
 569     my $meth = $Handlers{$type};
 570     $meth->($self, $line, $type, $totals) if $meth;
 571 };
 572
 573
 574 sub header_handler {
 575     my($self, $line, $type, $totals) = @_;
 576
 577     warn "Test header seen more than once!\n" if $self->{_seen_header};
 578
 579     $self->{_seen_header}++;
 580
 581     warn "1..M can only appear at the beginning or end of tests\n"
 582       if $totals->{seen} &&
 583          $totals->{max}  < $totals->{seen};
 584 };
 585
 586 sub test_handler {
 587     my($self, $line, $type, $totals) = @_;
 588
 589     my $curr = $totals->{seen};
 590     my $next = $self->{'next'};
 591     my $max  = $totals->{max};
 592     my $detail = $totals->{details}[-1];
 593
 594     if( $detail->{ok} ) {
 595         _print_ml_less("ok $curr/$max");
 596
 597         if( $detail->{type} eq 'skip' ) {
 598             $totals->{skip_reason} = $detail->{reason}
 599               unless defined $totals->{skip_reason};
 600             $totals->{skip_reason} = 'various reasons'
 601               if $totals->{skip_reason} ne $detail->{reason};
 602         }
 603     }
 604     else {
 605         _print_ml("NOK $curr");
 606     }
 607
 608     if( $curr > $next ) {
 609         print "Test output counter mismatch [test $curr]\n";
 610     }
 611     elsif( $curr < $next ) {
 612         print "Confused test output: test $curr answered after ".
 613               "test ", $next - 1, "\n";
 614     }
 615
 616 };
 617
 618 sub bailout_handler {
 619     my($self, $line, $type, $totals) = @_;
 620
 621     die "FAILED--Further testing stopped" .
 622       ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
 623 };
 624
 625
 626 sub _print_ml {
 627     print join '', $ML, @_ if $ML;
 628 }
 629
 630
 631 # For slow connections, we save lots of bandwidth by printing only once
 632 # per second.
 633 sub _print_ml_less {
 634     if ( $Last_ML_Print != time ) {
 635         _print_ml(@_);
 636         $Last_ML_Print = time;
 637     }
 638 }
 639
 640 sub _bonusmsg {
 641     my($tot) = @_;
 642
 643     my $bonusmsg = '';
 644     $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
 645                " UNEXPECTEDLY SUCCEEDED)")
 646         if $tot->{bonus};
 647
 648     if ($tot->{skipped}) {
 649         $bonusmsg .= ", $tot->{skipped} test"
 650                      . ($tot->{skipped} != 1 ? 's' : '');
 651         if ($tot->{sub_skipped}) {
 652             $bonusmsg .= " and $tot->{sub_skipped} subtest"
 653                          . ($tot->{sub_skipped} != 1 ? 's' : '');
 654         }
 655         $bonusmsg .= ' skipped';
 656     }
 657     elsif ($tot->{sub_skipped}) {
 658         $bonusmsg .= ", $tot->{sub_skipped} subtest"
 659                      . ($tot->{sub_skipped} != 1 ? 's' : '')
 660                      . " skipped";
 661     }
 662
 663     return $bonusmsg;
 664 }
 665
 666 # Test program go boom.
 667 sub _dubious_return {
 668     my($test, $tot, $estatus, $wstatus) = @_;
 669     my ($failed, $canon, $percent) = ('??', '??');
 670
 671     printf "$test->{ml}dubious\n\tTest returned status $estatus ".
 672            "(wstat %d, 0x%x)\n",
 673            $wstatus,$wstatus;
 674     print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
 675
 676     $tot->{bad}++;
 677
 678     if ($test->{max}) {
 679         if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
 680             print "\tafter all the subtests completed successfully\n";
 681             $percent = 0;
 682             $failed = 0;        # But we do not set $canon!
 683         }
 684         else {
 685             push @{$test->{failed}}, $test->{'next'}..$test->{max};
 686             $failed = @{$test->{failed}};
 687             (my $txt, $canon) = _canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
 688             $percent = 100*(scalar @{$test->{failed}})/$test->{max};
 689             print "DIED. ",$txt;
 690         }
 691     }
 692
 693     return { canon => $canon,  max => $test->{max} || '??',
 694              failed => $failed,
 695              percent => $percent,
 696              estat => $estatus, wstat => $wstatus,
 697            };
 698 }
 699
 700
 701 sub _create_fmts {
 702     my($failedtests) = @_;
 703
 704     my $failed_str = "Failed Test";
 705     my $middle_str = " Stat Wstat Total Fail  Failed  ";
 706     my $list_str = "List of Failed";
 707
 708     # Figure out our longest name string for formatting purposes.
 709     my $max_namelen = length($failed_str);
 710     foreach my $script (keys %$failedtests) {
 711         my $namelen = length $failedtests->{$script}->{name};
 712         $max_namelen = $namelen if $namelen > $max_namelen;
 713     }
 714
 715     my $list_len = $Columns - length($middle_str) - $max_namelen;
 716     if ($list_len < length($list_str)) {
 717         $list_len = length($list_str);
 718         $max_namelen = $Columns - length($middle_str) - $list_len;
 719         if ($max_namelen < length($failed_str)) {
 720             $max_namelen = length($failed_str);
 721             $Columns = $max_namelen + length($middle_str) + $list_len;
 722         }
 723     }
 724
 725     my $fmt_top = "format STDOUT_TOP =\n"
 726                   . sprintf("%-${max_namelen}s", $failed_str)
 727                   . $middle_str
 728                   . $list_str . "\n"
 729                   . "-" x $Columns
 730                   . "\n.\n";
 731
 732     my $fmt = "format STDOUT =\n"
 733               . "@" . "<" x ($max_namelen - 1)
 734               . "  @>> @>>>> @>>>> @>>> ^##.##%  "
 735               . "^" . "<" x ($list_len - 1) . "\n"
 736               . '{ $Curtest->{name}, $Curtest->{estat},'
 737               . '  $Curtest->{wstat}, $Curtest->{max},'
 738               . '  $Curtest->{failed}, $Curtest->{percent},'
 739               . '  $Curtest->{canon}'
 740               . "\n}\n"
 741               . "~~" . " " x ($Columns - $list_len - 2) . "^"
 742               . "<" x ($list_len - 1) . "\n"
 743               . '$Curtest->{canon}'
 744               . "\n.\n";
 745
 746     eval $fmt_top;
 747     die $@ if $@;
 748     eval $fmt;
 749     die $@ if $@;
 750
 751     return($fmt_top, $fmt);
 752 }
 753
 754 sub _canonfailed ($$@) {
 755     my($max,$skipped,@failed) = @_;
 756     my %seen;
 757     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
 758     my $failed = @failed;
 759     my @result = ();
 760     my @canon = ();
 761     my $min;
 762     my $last = $min = shift @failed;
 763     my $canon;
 764     if (@failed) {
 765         for (@failed, $failed[-1]) { # don't forget the last one
 766             if ($_ > $last+1 || $_ == $last) {
 767                 if ($min == $last) {
 768                     push @canon, $last;
 769                 } else {
 770                     push @canon, "$min-$last";
 771                 }
 772                 $min = $_;
 773             }
 774             $last = $_;
 775         }
 776         local $" = ", ";
 777         push @result, "FAILED tests @canon\n";
 778         $canon = join ' ', @canon;
 779     } else {
 780         push @result, "FAILED test $last\n";
 781         $canon = $last;
 782     }
 783
 784     push @result, "\tFailed $failed/$max tests, ";
 785     if ($max) {
 786         push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay";
 787     } else {
 788         push @result, "?% okay";
 789     }
 790     my $ender = 's' x ($skipped > 1);
 791     if ($skipped) {
 792         my $good = $max - $failed - $skipped;
 793         my $skipmsg = " (less $skipped skipped test$ender: $good okay, ";
 794         if ($max) {
 795             my $goodper = sprintf("%.2f",100*($good/$max));
 796             $skipmsg .= "$goodper%)";
 797         } else {
 798             $skipmsg .= "?%)";
 799         }
 800         push @result, $skipmsg;
 801     }
 802     push @result, "\n";
 803     my $txt = join "", @result;
 804     ($txt, $canon);
 805 }
 806
 807 =end _private
 808
 809 =back
 810
 811 =cut
 812
 813
 814 1;
 815 __END__
 816
 817
 818 =head1 EXPORT
 819
 820 C<&runtests> is exported by Test::Harness by default.
 821
 822 C<$verbose>, C<$switches> and C<$debug> are exported upon request.
 823
 824 =head1 DIAGNOSTICS
 825
 826 =over 4
 827
 828 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 829
 830 If all tests are successful some statistics about the performance are
 831 printed.
 832
 833 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 834
 835 For any single script that has failing subtests statistics like the
 836 above are printed.
 837
 838 =item C<Test returned status %d (wstat %d)>
 839
 840 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
 841 and C<$?> are printed in a message similar to the above.
 842
 843 =item C<Failed 1 test, %.2f%% okay. %s>
 844
 845 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 846
 847 If not all tests were successful, the script dies with one of the
 848 above messages.
 849
 850 =item C<FAILED--Further testing stopped: %s>
 851
 852 If a single subtest decides that further testing will not make sense,
 853 the script dies with this message.
 854
 855 =back
 856
 857 =head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS
 858
 859 Test::Harness sets these before executing the individual tests.
 860
 861 =over 4
 862
 863 =item C<HARNESS_ACTIVE>
 864
 865 This is set to a true value.  It allows the tests to determine if they
 866 are being executed through the harness or by any other means.
 867
 868 =item C<HARNESS_VERSION>
 869
 870 This is the version of Test::Harness.
 871
 872 =back
 873
 874 =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
 875
 876 =over 4
 877
 878 =item C<HARNESS_COLUMNS>
 879
 880 This value will be used for the width of the terminal. If it is not
 881 set then it will default to C<COLUMNS>. If this is not set, it will
 882 default to 80. Note that users of Bourne-sh based shells will need to
 883 C<export COLUMNS> for this module to use that variable.
 884
 885 =item C<HARNESS_COMPILE_TEST>
 886
 887 When true it will make harness attempt to compile the test using
 888 C<perlcc> before running it.
 889
 890 B<NOTE> This currently only works when sitting in the perl source
 891 directory!
 892
 893 =item C<HARNESS_DEBUG>
 894
 895 If true, Test::Harness will print debugging information about itself as
 896 it runs the tests.  This is different from C<HARNESS_VERBOSE>, which prints
 897 the output from the test being run.  Setting C<$Test::Harness::Debug> will
 898 override this, or you can use the C<-d> switch in the F<prove> utility.
 899
 900 =item C<HARNESS_FILELEAK_IN_DIR>
 901
 902 When set to the name of a directory, harness will check after each
 903 test whether new files appeared in that directory, and report them as
 904
 905   LEAKED FILES: scr.tmp 0 my.db
 906
 907 If relative, directory name is with respect to the current directory at
 908 the moment runtests() was called.  Putting absolute path into
 909 C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
 910
 911 =item C<HARNESS_IGNORE_EXITCODE>
 912
 913 Makes harness ignore the exit status of child processes when defined.
 914
 915 =item C<HARNESS_NOTTY>
 916
 917 When set to a true value, forces it to behave as though STDOUT were
 918 not a console.  You may need to set this if you don't want harness to
 919 output more frequent progress messages using carriage returns.  Some
 920 consoles may not handle carriage returns properly (which results in a
 921 somewhat messy output).
 922
 923 =item C<HARNESS_PERL>
 924
 925 Usually your tests will be run by C<$^X>, the currently-executing Perl.
 926 However, you may want to have it run by a different executable, such as
 927 a threading perl, or a different version.
 928
 929 If you're using the F<prove> utility, you can use the C<--perl> switch.
 930
 931 =item C<HARNESS_PERL_SWITCHES>
 932
 933 Its value will be prepended to the switches used to invoke perl on
 934 each test.  For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
 935 run all tests with all warnings enabled.
 936
 937 =item C<HARNESS_VERBOSE>
 938
 939 If true, Test::Harness will output the verbose results of running
 940 its tests.  Setting C<$Test::Harness::verbose> will override this,
 941 or you can use the C<-v> switch in the F<prove> utility.
 942
 943 =back
 944
 945 =head1 EXAMPLE
 946
 947 Here's how Test::Harness tests itself
 948
 949   $ cd ~/src/devel/Test-Harness
 950   $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
 951     $verbose=0; runtests @ARGV;' t/*.t
 952   Using /home/schwern/src/devel/Test-Harness/blib
 953   t/base..............ok
 954   t/nonumbers.........ok
 955   t/ok................ok
 956   t/test-harness......ok
 957   All tests successful.
 958   Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
 959
 960 =head1 SEE ALSO
 961
 962 The included F<prove> utility for running test scripts from the command line,
 963 L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
 964 the underlying timing routines, and L<Devel::Cover> for test coverage
 965 analysis.
 966
 967 =head1 TODO
 968
 969 Provide a way of running tests quietly (ie. no printing) for automated
 970 validation of tests.  This will probably take the form of a version
 971 of runtests() which rather than printing its output returns raw data
 972 on the state of the tests.  (Partially done in Test::Harness::Straps)
 973
 974 Document the format.
 975
 976 Fix HARNESS_COMPILE_TEST without breaking its core usage.
 977
 978 Figure a way to report test names in the failure summary.
 979
 980 Rework the test summary so long test names are not truncated as badly.
 981 (Partially done with new skip test styles)
 982
 983 Add option for coverage analysis.
 984
 985 Trap STDERR.
 986
 987 Implement Straps total_results()
 988
 989 Remember exit code
 990
 991 Completely redo the print summary code.
 992
 993 Implement Straps callbacks.  (experimentally implemented)
 994
 995 Straps->analyze_file() not taint clean, don't know if it can be
 996
 997 Fix that damned VMS nit.
 998
 999 HARNESS_TODOFAIL to display TODO failures
1000
1001 Add a test for verbose.
1002
1003 Change internal list of test results to a hash.
1004
1005 Fix stats display when there's an overrun.
1006
1007 Fix so perls with spaces in the filename work.
1008
1009 Keeping whittling away at _run_all_tests()
1010
1011 Clean up how the summary is printed.  Get rid of those damned formats.
1012
1013 =head1 BUGS
1014
1015 HARNESS_COMPILE_TEST currently assumes it's run from the Perl source
1016 directory.
1017
1018 Please use the CPAN bug ticketing system at L<http://rt.cpan.org/>.
1019 You can also mail bugs, fixes and enhancements to
1020 C<< <bug-test-harness >> at C<< rt.cpan.org> >>.
1021
1022 =head1 AUTHORS
1023
1024 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
1025 sure is, that it was inspired by Larry Wall's TEST script that came
1026 with perl distributions for ages. Numerous anonymous contributors
1027 exist.  Andreas Koenig held the torch for many years, and then
1028 Michael G Schwern.
1029
1030 Current maintainer is Andy Lester C<< <andy at petdance.com> >>.
1031
1032 =head1 COPYRIGHT
1033
1034 Copyright 2002-2005
1035 by Michael G Schwern C<< <schwern at pobox.com> >>,
1036 Andy Lester C<< <andy at petdance.com> >>.
1037
1038 This program is free software; you can redistribute it and/or
1039 modify it under the same terms as Perl itself.
1040
1041 See L<http://www.perl.com/perl/misc/Artistic.html>.
1042
1043 =cut