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