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_01';
  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             $out .= swrite( $fmt_top );
 565             for my $script (sort keys %{$todo_passed||{}}) {
 566                 my $Curtest = $todo_passed->{$script};
 567                 $out .= swrite( $fmt, @{ $Curtest }{qw(name estat wstat max failed canon)} );
 568             }
 569         }
 570     }
 571     elsif (!$tot->{tests}){
 572         die "FAILED--no tests were run for some reason.\n";
 573     }
 574     elsif (!$tot->{max}) {
 575         my $blurb = $tot->{tests}==1 ? "script" : "scripts";
 576         die "FAILED--$tot->{tests} test $blurb could be run, ".
 577             "alas--no output ever seen\n";
 578     }
 579     else {
 580         my $subresults = sprintf( " %d/%d subtests failed.",
 581                               $tot->{max} - $tot->{ok}, $tot->{max} );
 582
 583         my($fmt_top, $fmt1, $fmt2) = _create_fmts("Failed Test",$failedtests);
 584
 585         # Now write to formats
 586         $out .= swrite( $fmt_top );
 587         for my $script (sort keys %$failedtests) {
 588             my $Curtest = $failedtests->{$script};
 589             $out .= swrite( $fmt1, @{ $Curtest }{qw(name estat wstat max failed canon)} );
 590             $out .= swrite( $fmt2, $Curtest->{canon} );
 591         }
 592         if ($tot->{bad}) {
 593             $bonusmsg =~ s/^,\s*//;
 594             $out .= "$bonusmsg.\n" if $bonusmsg;
 595             $out .= "Failed $tot->{bad}/$tot->{tests} test scripts.$subresults\n";
 596         }
 597     }
 598
 599     $out .= sprintf("Files=%d, Tests=%d, %s\n",
 600            $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
 601     return $out;
 602 }
 603
 604 sub swrite {
 605     my $format = shift;
 606     $^A = '';
 607     formline($format,@_);
 608     my $out = $^A;
 609     $^A = '';
 610     return $out;
 611 }
 612
 613
 614 my %Handlers = (
 615     header => \&header_handler,
 616     test => \&test_handler,
 617     bailout => \&bailout_handler,
 618 );
 619
 620 $Strap->{callback} = \&strap_callback;
 621 sub strap_callback {
 622     my($self, $line, $type, $totals) = @_;
 623     print $line if $Verbose;
 624
 625     my $meth = $Handlers{$type};
 626     $meth->($self, $line, $type, $totals) if $meth;
 627 };
 628
 629
 630 sub header_handler {
 631     my($self, $line, $type, $totals) = @_;
 632
 633     warn "Test header seen more than once!\n" if $self->{_seen_header};
 634
 635     $self->{_seen_header}++;
 636
 637     warn "1..M can only appear at the beginning or end of tests\n"
 638       if $totals->{seen} &&
 639          $totals->{max}  < $totals->{seen};
 640 };
 641
 642 sub test_handler {
 643     my($self, $line, $type, $totals) = @_;
 644
 645     my $curr = $totals->{seen};
 646     my $next = $self->{'next'};
 647     my $max  = $totals->{max};
 648     my $detail = $totals->{details}[-1];
 649
 650     if( $detail->{ok} ) {
 651         _print_ml_less("ok $curr/$max");
 652
 653         if( $detail->{type} eq 'skip' ) {
 654             $totals->{skip_reason} = $detail->{reason}
 655               unless defined $totals->{skip_reason};
 656             $totals->{skip_reason} = 'various reasons'
 657               if $totals->{skip_reason} ne $detail->{reason};
 658         }
 659     }
 660     else {
 661         _print_ml("NOK $curr");
 662     }
 663
 664     if( $curr > $next ) {
 665         print "Test output counter mismatch [test $curr]\n";
 666     }
 667     elsif( $curr < $next ) {
 668         print "Confused test output: test $curr answered after ".
 669               "test ", $next - 1, "\n";
 670     }
 671
 672 };
 673
 674 sub bailout_handler {
 675     my($self, $line, $type, $totals) = @_;
 676
 677     die "FAILED--Further testing stopped" .
 678       ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
 679 };
 680
 681
 682 sub _print_ml {
 683     print join '', $ML, @_ if $ML;
 684 }
 685
 686
 687 # Print updates only once per second.
 688 sub _print_ml_less {
 689     my $now = CORE::time;
 690     if ( $Last_ML_Print != $now ) {
 691         _print_ml(@_);
 692         $Last_ML_Print = $now;
 693     }
 694 }
 695
 696 sub _bonusmsg {
 697     my($tot) = @_;
 698
 699     my $bonusmsg = '';
 700     $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
 701                " UNEXPECTEDLY SUCCEEDED)")
 702         if $tot->{bonus};
 703
 704     if ($tot->{skipped}) {
 705         $bonusmsg .= ", $tot->{skipped} test"
 706                      . ($tot->{skipped} != 1 ? 's' : '');
 707         if ($tot->{sub_skipped}) {
 708             $bonusmsg .= " and $tot->{sub_skipped} subtest"
 709                          . ($tot->{sub_skipped} != 1 ? 's' : '');
 710         }
 711         $bonusmsg .= ' skipped';
 712     }
 713     elsif ($tot->{sub_skipped}) {
 714         $bonusmsg .= ", $tot->{sub_skipped} subtest"
 715                      . ($tot->{sub_skipped} != 1 ? 's' : '')
 716                      . " skipped";
 717     }
 718     return $bonusmsg;
 719 }
 720
 721 # Test program go boom.
 722 sub _dubious_return {
 723     my($test, $tot, $estatus, $wstatus) = @_;
 724
 725     my $failed = '??';
 726     my $canon  = '??';
 727
 728     printf "$test->{ml}dubious\n\tTest returned status $estatus ".
 729            "(wstat %d, 0x%x)\n",
 730            $wstatus,$wstatus;
 731     print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
 732
 733     $tot->{bad}++;
 734
 735     if ($test->{max}) {
 736         if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
 737             print "\tafter all the subtests completed successfully\n";
 738             $failed = 0;        # But we do not set $canon!
 739         }
 740         else {
 741             push @{$test->{failed}}, $test->{'next'}..$test->{max};
 742             $failed = @{$test->{failed}};
 743             (my $txt, $canon) = _canondetail($test->{max},$test->{skipped},'Failed',@{$test->{failed}});
 744             print "DIED. ",$txt;
 745         }
 746     }
 747
 748     return { canon => $canon,  max => $test->{max} || '??',
 749              failed => $failed,
 750              estat => $estatus, wstat => $wstatus,
 751            };
 752 }
 753
 754
 755 sub _create_fmts {
 756     my $failed_str = shift;
 757     my $failedtests = shift;
 758
 759     my ($type) = split /\s/,$failed_str;
 760     my $short = substr($type,0,4);
 761     my $total = $short eq 'Pass' ? 'TODOs' : 'Total';
 762     my $middle_str = " Stat Wstat $total $short  ";
 763     my $list_str = "List of $type";
 764
 765     # Figure out our longest name string for formatting purposes.
 766     my $max_namelen = length($failed_str);
 767     foreach my $script (keys %$failedtests) {
 768         my $namelen = length $failedtests->{$script}->{name};
 769         $max_namelen = $namelen if $namelen > $max_namelen;
 770     }
 771
 772     my $list_len = $Columns - length($middle_str) - $max_namelen;
 773     if ($list_len < length($list_str)) {
 774         $list_len = length($list_str);
 775         $max_namelen = $Columns - length($middle_str) - $list_len;
 776         if ($max_namelen < length($failed_str)) {
 777             $max_namelen = length($failed_str);
 778             $Columns = $max_namelen + length($middle_str) + $list_len;
 779         }
 780     }
 781
 782     my $fmt_top =   sprintf("%-${max_namelen}s", $failed_str)
 783                   . $middle_str
 784                   . $list_str . "\n"
 785                   . "-" x $Columns
 786                   . "\n";
 787
 788     my $fmt1 =  "@" . "<" x ($max_namelen - 1)
 789               . "  @>> @>>>> @>>>> @>>>  "
 790               . "^" . "<" x ($list_len - 1) . "\n";
 791     my $fmt2 =  "~~" . " " x ($Columns - $list_len - 2) . "^"
 792               . "<" x ($list_len - 1) . "\n";
 793
 794     return($fmt_top, $fmt1, $fmt2);
 795 }
 796
 797 sub _canondetail {
 798     my $max = shift;
 799     my $skipped = shift;
 800     my $type = shift;
 801     my @detail = @_;
 802     my %seen;
 803     @detail = sort {$a <=> $b} grep !$seen{$_}++, @detail;
 804     my $detail = @detail;
 805     my @result = ();
 806     my @canon = ();
 807     my $min;
 808     my $last = $min = shift @detail;
 809     my $canon;
 810     my $uc_type = uc($type);
 811     if (@detail) {
 812         for (@detail, $detail[-1]) { # don't forget the last one
 813             if ($_ > $last+1 || $_ == $last) {
 814                 push @canon, ($min == $last) ? $last : "$min-$last";
 815                 $min = $_;
 816             }
 817             $last = $_;
 818         }
 819         local $" = ", ";
 820         push @result, "$uc_type tests @canon\n";
 821         $canon = join ' ', @canon;
 822     }
 823     else {
 824         push @result, "$uc_type test $last\n";
 825         $canon = $last;
 826     }
 827
 828     return (join("", @result), $canon)
 829         if $type=~/todo/i;
 830     push @result, "\t$type $detail/$max tests, ";
 831     if ($max) {
 832         push @result, sprintf("%.2f",100*(1-$detail/$max)), "% okay";
 833     }
 834     else {
 835         push @result, "?% okay";
 836     }
 837     my $ender = 's' x ($skipped > 1);
 838     if ($skipped) {
 839         my $good = $max - $detail - $skipped;
 840         my $skipmsg = " (less $skipped skipped test$ender: $good okay, ";
 841         if ($max) {
 842             my $goodper = sprintf("%.2f",100*($good/$max));
 843             $skipmsg .= "$goodper%)";
 844         }
 845         else {
 846             $skipmsg .= "?%)";
 847         }
 848         push @result, $skipmsg;
 849     }
 850     push @result, "\n";
 851     my $txt = join "", @result;
 852     return ($txt, $canon);
 853 }
 854
 855 1;
 856 __END__
 857
 858
 859 =head1 EXPORT
 860
 861 C<&runtests> is exported by Test::Harness by default.
 862
 863 C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
 864 exported upon request.
 865
 866 =head1 DIAGNOSTICS
 867
 868 =over 4
 869
 870 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 871
 872 If all tests are successful some statistics about the performance are
 873 printed.
 874
 875 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 876
 877 For any single script that has failing subtests statistics like the
 878 above are printed.
 879
 880 =item C<Test returned status %d (wstat %d)>
 881
 882 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
 883 and C<$?> are printed in a message similar to the above.
 884
 885 =item C<Failed 1 test, %.2f%% okay. %s>
 886
 887 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 888
 889 If not all tests were successful, the script dies with one of the
 890 above messages.
 891
 892 =item C<FAILED--Further testing stopped: %s>
 893
 894 If a single subtest decides that further testing will not make sense,
 895 the script dies with this message.
 896
 897 =back
 898
 899 =head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS
 900
 901 Test::Harness sets these before executing the individual tests.
 902
 903 =over 4
 904
 905 =item C<HARNESS_ACTIVE>
 906
 907 This is set to a true value.  It allows the tests to determine if they
 908 are being executed through the harness or by any other means.
 909
 910 =item C<HARNESS_VERSION>
 911
 912 This is the version of Test::Harness.
 913
 914 =back
 915
 916 =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
 917
 918 =over 4
 919
 920 =item C<HARNESS_COLUMNS>
 921
 922 This value will be used for the width of the terminal. If it is not
 923 set then it will default to C<COLUMNS>. If this is not set, it will
 924 default to 80. Note that users of Bourne-sh based shells will need to
 925 C<export COLUMNS> for this module to use that variable.
 926
 927 =item C<HARNESS_COMPILE_TEST>
 928
 929 When true it will make harness attempt to compile the test using
 930 C<perlcc> before running it.
 931
 932 B<NOTE> This currently only works when sitting in the perl source
 933 directory!
 934
 935 =item C<HARNESS_DEBUG>
 936
 937 If true, Test::Harness will print debugging information about itself as
 938 it runs the tests.  This is different from C<HARNESS_VERBOSE>, which prints
 939 the output from the test being run.  Setting C<$Test::Harness::Debug> will
 940 override this, or you can use the C<-d> switch in the F<prove> utility.
 941
 942 =item C<HARNESS_FILELEAK_IN_DIR>
 943
 944 When set to the name of a directory, harness will check after each
 945 test whether new files appeared in that directory, and report them as
 946
 947   LEAKED FILES: scr.tmp 0 my.db
 948
 949 If relative, directory name is with respect to the current directory at
 950 the moment runtests() was called.  Putting absolute path into
 951 C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
 952
 953 =item C<HARNESS_NOTTY>
 954
 955 When set to a true value, forces it to behave as though STDOUT were
 956 not a console.  You may need to set this if you don't want harness to
 957 output more frequent progress messages using carriage returns.  Some
 958 consoles may not handle carriage returns properly (which results in a
 959 somewhat messy output).
 960
 961 =item C<HARNESS_PERL>
 962
 963 Usually your tests will be run by C<$^X>, the currently-executing Perl.
 964 However, you may want to have it run by a different executable, such as
 965 a threading perl, or a different version.
 966
 967 If you're using the F<prove> utility, you can use the C<--perl> switch.
 968
 969 =item C<HARNESS_PERL_SWITCHES>
 970
 971 Its value will be prepended to the switches used to invoke perl on
 972 each test.  For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
 973 run all tests with all warnings enabled.
 974
 975 =item C<HARNESS_TIMER>
 976
 977 Setting this to true will make the harness display the number of
 978 milliseconds each test took.  You can also use F<prove>'s C<--timer>
 979 switch.
 980
 981 =item C<HARNESS_VERBOSE>
 982
 983 If true, Test::Harness will output the verbose results of running
 984 its tests.  Setting C<$Test::Harness::verbose> will override this,
 985 or you can use the C<-v> switch in the F<prove> utility.
 986
 987 =back
 988
 989 =head1 EXAMPLE
 990
 991 Here's how Test::Harness tests itself
 992
 993   $ cd ~/src/devel/Test-Harness
 994   $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
 995     $verbose=0; runtests @ARGV;' t/*.t
 996   Using /home/schwern/src/devel/Test-Harness/blib
 997   t/base..............ok
 998   t/nonumbers.........ok
 999   t/ok................ok
1000   t/test-harness......ok
1001   All tests successful.
1002   Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
1003
1004 =head1 SEE ALSO
1005
1006 The included F<prove> utility for running test scripts from the command line,
1007 L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
1008 the underlying timing routines, and L<Devel::Cover> for test coverage
1009 analysis.
1010
1011 =head1 TODO
1012
1013 Provide a way of running tests quietly (ie. no printing) for automated
1014 validation of tests.  This will probably take the form of a version
1015 of runtests() which rather than printing its output returns raw data
1016 on the state of the tests.  (Partially done in Test::Harness::Straps)
1017
1018 Document the format.
1019
1020 Fix HARNESS_COMPILE_TEST without breaking its core usage.
1021
1022 Figure a way to report test names in the failure summary.
1023
1024 Rework the test summary so long test names are not truncated as badly.
1025 (Partially done with new skip test styles)
1026
1027 Add option for coverage analysis.
1028
1029 Trap STDERR.
1030
1031 Implement Straps total_results()
1032
1033 Remember exit code
1034
1035 Completely redo the print summary code.
1036
1037 Implement Straps callbacks.  (experimentally implemented)
1038
1039 Straps->analyze_file() not taint clean, don't know if it can be
1040
1041 Fix that damned VMS nit.
1042
1043 Add a test for verbose.
1044
1045 Change internal list of test results to a hash.
1046
1047 Fix stats display when there's an overrun.
1048
1049 Fix so perls with spaces in the filename work.
1050
1051 Keeping whittling away at _run_all_tests()
1052
1053 Clean up how the summary is printed.  Get rid of those damned formats.
1054
1055 =head1 BUGS
1056
1057 Please report any bugs or feature requests to
1058 C<bug-test-harness at rt.cpan.org>, or through the web interface at
1059 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
1060 I will be notified, and then you'll automatically be notified of progress on
1061 your bug as I make changes.
1062
1063 =head1 SUPPORT
1064
1065 You can find documentation for this module with the F<perldoc> command.
1066
1067     perldoc Test::Harness
1068
1069 You can get docs for F<prove> with
1070
1071     prove --man
1072
1073 You can also look for information at:
1074
1075 =over 4
1076
1077 =item * AnnoCPAN: Annotated CPAN documentation
1078
1079 L<http://annocpan.org/dist/Test-Harness>
1080
1081 =item * CPAN Ratings
1082
1083 L<http://cpanratings.perl.org/d/Test-Harness>
1084
1085 =item * RT: CPAN's request tracker
1086
1087 L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Harness>
1088
1089 =item * Search CPAN
1090
1091 L<http://search.cpan.org/dist/Test-Harness>
1092
1093 =back
1094
1095 =head1 SOURCE CODE
1096
1097 The source code repository for Test::Harness is at
1098 L<http://svn.perl.org/modules/Test-Harness>.
1099
1100 =head1 AUTHORS
1101
1102 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
1103 sure is, that it was inspired by Larry Wall's F<TEST> script that came
1104 with perl distributions for ages. Numerous anonymous contributors
1105 exist.  Andreas Koenig held the torch for many years, and then
1106 Michael G Schwern.
1107
1108 Current maintainer is Andy Lester C<< <andy at petdance.com> >>.
1109
1110 =head1 COPYRIGHT
1111
1112 Copyright 2002-2006
1113 by Michael G Schwern C<< <schwern at pobox.com> >>,
1114 Andy Lester C<< <andy at petdance.com> >>.
1115
1116 This program is free software; you can redistribute it and/or
1117 modify it under the same terms as Perl itself.
1118
1119 See L<http://www.perl.com/perl/misc/Artistic.html>.
1120
1121 =cut