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