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