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