lib/Test/Harness.pm

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