lib/Test/Harness.pm

   1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
   2 # $Id: Harness.pm,v 1.47 2003/04/24 19:33:05 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.28';
  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
 332 This is just _run_all_tests() plus _show_results()
 333
 334 =cut
 335
 336 sub runtests {
 337     my(@tests) = @_;
 338
 339     local ($\, $,);
 340
 341     my($tot, $failedtests) = _run_all_tests(@tests);
 342     _show_results($tot, $failedtests);
 343
 344     my $ok = _all_ok($tot);
 345
 346     assert(($ok xor keys %$failedtests),
 347            q{ok status jives with $failedtests});
 348
 349     return $ok;
 350 }
 351
 352 =begin _private
 353
 354 =item B<_all_ok>
 355
 356   my $ok = _all_ok(\%tot);
 357
 358 Tells you if this test run is overall successful or not.
 359
 360 =cut
 361
 362 sub _all_ok {
 363     my($tot) = shift;
 364
 365     return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0;
 366 }
 367
 368 =item B<_globdir>
 369
 370   my @files = _globdir $dir;
 371
 372 Returns all the files in a directory.  This is shorthand for backwards
 373 compatibility on systems where glob() doesn't work right.
 374
 375 =cut
 376
 377 sub _globdir {
 378     opendir DIRH, shift;
 379     my @f = readdir DIRH;
 380     closedir DIRH;
 381
 382     return @f;
 383 }
 384
 385 =item B<_run_all_tests>
 386
 387   my($total, $failed) = _run_all_tests(@test_files);
 388
 389 Runs all the given @test_files (as runtests()) but does it quietly (no
 390 report).  $total is a hash ref summary of all the tests run.  Its keys
 391 and values are this:
 392
 393     bonus           Number of individual todo tests unexpectedly passed
 394     max             Number of individual tests ran
 395     ok              Number of individual tests passed
 396     sub_skipped     Number of individual tests skipped
 397     todo            Number of individual todo tests
 398
 399     files           Number of test files ran
 400     good            Number of test files passed
 401     bad             Number of test files failed
 402     tests           Number of test files originally given
 403     skipped         Number of test files skipped
 404
 405 If $total->{bad} == 0 and $total->{max} > 0, you've got a successful
 406 test.
 407
 408 $failed is a hash ref of all the test scripts which failed.  Each key
 409 is the name of a test script, each value is another hash representing
 410 how that script failed.  Its keys are these:
 411
 412     name        Name of the test which failed
 413     estat       Script's exit value
 414     wstat       Script's wait status
 415     max         Number of individual tests
 416     failed      Number which failed
 417     percent     Percentage of tests which failed
 418     canon       List of tests which failed (as string).
 419
 420 Needless to say, $failed should be empty if everything passed.
 421
 422 B<NOTE> Currently this function is still noisy.  I'm working on it.
 423
 424 =cut
 425
 426 #'#
 427 sub _run_all_tests {
 428     my(@tests) = @_;
 429     local($|) = 1;
 430     my(%failedtests);
 431
 432     # Test-wide totals.
 433     my(%tot) = (
 434                 bonus    => 0,
 435                 max      => 0,
 436                 ok       => 0,
 437                 files    => 0,
 438                 bad      => 0,
 439                 good     => 0,
 440                 tests    => scalar @tests,
 441                 sub_skipped  => 0,
 442                 todo     => 0,
 443                 skipped  => 0,
 444                 bench    => 0,
 445                );
 446
 447     my @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
 448     my $t_start = new Benchmark;
 449
 450     my $width = _leader_width(@tests);
 451     foreach my $tfile (@tests) {
 452
 453         my($leader, $ml) = _mk_leader($tfile, $width);
 454         local $ML = $ml;
 455         print $leader;
 456
 457         $tot{files}++;
 458
 459         $Strap->{_seen_header} = 0;
 460         my %results = $Strap->analyze_file($tfile) or
 461           do { warn "$Strap->{error}\n";  next };
 462
 463         # state of the current test.
 464         my @failed = grep { !$results{details}[$_-1]{ok} }
 465                      1..@{$results{details}};
 466         my %test = (
 467                     ok          => $results{ok},
 468                     'next'      => $Strap->{'next'},
 469                     max         => $results{max},
 470                     failed      => \@failed,
 471                     bonus       => $results{bonus},
 472                     skipped     => $results{skip},
 473                     skip_reason => $results{skip_reason},
 474                     skip_all    => $Strap->{skip_all},
 475                     ml          => $ml,
 476                    );
 477
 478         $tot{bonus}       += $results{bonus};
 479         $tot{max}         += $results{max};
 480         $tot{ok}          += $results{ok};
 481         $tot{todo}        += $results{todo};
 482         $tot{sub_skipped} += $results{skip};
 483
 484         my($estatus, $wstatus) = @results{qw(exit wait)};
 485
 486         if ($results{passing}) {
 487             if ($test{max} and $test{skipped} + $test{bonus}) {
 488                 my @msg;
 489                 push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
 490                     if $test{skipped};
 491                 push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded")
 492                     if $test{bonus};
 493                 print "$test{ml}ok\n        ".join(', ', @msg)."\n";
 494             } elsif ($test{max}) {
 495                 print "$test{ml}ok\n";
 496             } elsif (defined $test{skip_all} and length $test{skip_all}) {
 497                 print "skipped\n        all skipped: $test{skip_all}\n";
 498                 $tot{skipped}++;
 499             } else {
 500                 print "skipped\n        all skipped: no reason given\n";
 501                 $tot{skipped}++;
 502             }
 503             $tot{good}++;
 504         }
 505         else {
 506             # List unrun tests as failures.
 507             if ($test{'next'} <= $test{max}) {
 508                 push @{$test{failed}}, $test{'next'}..$test{max};
 509             }
 510             # List overruns as failures.
 511             else {
 512                 my $details = $results{details};
 513                 foreach my $overrun ($test{max}+1..@$details)
 514                 {
 515                     next unless ref $details->[$overrun-1];
 516                     push @{$test{failed}}, $overrun
 517                 }
 518             }
 519
 520             if ($wstatus) {
 521                 $failedtests{$tfile} = _dubious_return(\%test, \%tot,
 522                                                        $estatus, $wstatus);
 523                 $failedtests{$tfile}{name} = $tfile;
 524             }
 525             elsif($results{seen}) {
 526                 if (@{$test{failed}}) {
 527                     my ($txt, $canon) = canonfailed($test{max},$test{skipped},
 528                                                     @{$test{failed}});
 529                     print "$test{ml}$txt";
 530                     $failedtests{$tfile} = { canon   => $canon,
 531                                              max     => $test{max},
 532                                              failed  => scalar @{$test{failed}},
 533                                              name    => $tfile,
 534                                              percent => 100*(scalar @{$test{failed}})/$test{max},
 535                                              estat   => '',
 536                                              wstat   => '',
 537                                            };
 538                 } else {
 539                     print "Don't know which tests failed: got $test{ok} ok, ".
 540                           "expected $test{max}\n";
 541                     $failedtests{$tfile} = { canon   => '??',
 542                                              max     => $test{max},
 543                                              failed  => '??',
 544                                              name    => $tfile,
 545                                              percent => undef,
 546                                              estat   => '',
 547                                              wstat   => '',
 548                                            };
 549                 }
 550                 $tot{bad}++;
 551             } else {
 552                 print "FAILED before any test output arrived\n";
 553                 $tot{bad}++;
 554                 $failedtests{$tfile} = { canon       => '??',
 555                                          max         => '??',
 556                                          failed      => '??',
 557                                          name        => $tfile,
 558                                          percent     => undef,
 559                                          estat       => '',
 560                                          wstat       => '',
 561                                        };
 562             }
 563         }
 564
 565         if (defined $Files_In_Dir) {
 566             my @new_dir_files = _globdir $Files_In_Dir;
 567             if (@new_dir_files != @dir_files) {
 568                 my %f;
 569                 @f{@new_dir_files} = (1) x @new_dir_files;
 570                 delete @f{@dir_files};
 571                 my @f = sort keys %f;
 572                 print "LEAKED FILES: @f\n";
 573                 @dir_files = @new_dir_files;
 574             }
 575         }
 576     }
 577     $tot{bench} = timediff(new Benchmark, $t_start);
 578
 579     $Strap->_restore_PERL5LIB;
 580
 581     return(\%tot, \%failedtests);
 582 }
 583
 584 =item B<_mk_leader>
 585
 586   my($leader, $ml) = _mk_leader($test_file, $width);
 587
 588 Generates the 't/foo........' $leader for the given $test_file as well
 589 as a similar version which will overwrite the current line (by use of
 590 \r and such).  $ml may be empty if Test::Harness doesn't think you're
 591 on TTY.
 592
 593 The $width is the width of the "yada/blah.." string.
 594
 595 =cut
 596
 597 sub _mk_leader {
 598     my($te, $width) = @_;
 599     chomp($te);
 600     $te =~ s/\.\w+$/./;
 601
 602     if ($^O eq 'VMS') { $te =~ s/^.*\.t\./\[.t./s; }
 603     my $blank = (' ' x 77);
 604     my $leader = "$te" . '.' x ($width - length($te));
 605     my $ml = "";
 606
 607     $ml = "\r$blank\r$leader"
 608       if -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose;
 609
 610     return($leader, $ml);
 611 }
 612
 613 =item B<_leader_width>
 614
 615   my($width) = _leader_width(@test_files);
 616
 617 Calculates how wide the leader should be based on the length of the
 618 longest test name.
 619
 620 =cut
 621
 622 sub _leader_width {
 623     my $maxlen = 0;
 624     my $maxsuflen = 0;
 625     foreach (@_) {
 626         my $suf    = /\.(\w+)$/ ? $1 : '';
 627         my $len    = length;
 628         my $suflen = length $suf;
 629         $maxlen    = $len    if $len    > $maxlen;
 630         $maxsuflen = $suflen if $suflen > $maxsuflen;
 631     }
 632     # + 3 : we want three dots between the test name and the "ok"
 633     return $maxlen + 3 - $maxsuflen;
 634 }
 635
 636
 637 sub _show_results {
 638     my($tot, $failedtests) = @_;
 639
 640     my $pct;
 641     my $bonusmsg = _bonusmsg($tot);
 642
 643     if (_all_ok($tot)) {
 644         print "All tests successful$bonusmsg.\n";
 645     } elsif (!$tot->{tests}){
 646         die "FAILED--no tests were run for some reason.\n";
 647     } elsif (!$tot->{max}) {
 648         my $blurb = $tot->{tests}==1 ? "script" : "scripts";
 649         die "FAILED--$tot->{tests} test $blurb could be run, ".
 650             "alas--no output ever seen\n";
 651     } else {
 652         $pct = sprintf("%.2f", $tot->{good} / $tot->{tests} * 100);
 653         my $percent_ok = 100*$tot->{ok}/$tot->{max};
 654         my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
 655                               $tot->{max} - $tot->{ok}, $tot->{max},
 656                               $percent_ok;
 657
 658         my($fmt_top, $fmt) = _create_fmts($failedtests);
 659
 660         # Now write to formats
 661         for my $script (sort keys %$failedtests) {
 662           $Curtest = $failedtests->{$script};
 663           write;
 664         }
 665         if ($tot->{bad}) {
 666             $bonusmsg =~ s/^,\s*//;
 667             print "$bonusmsg.\n" if $bonusmsg;
 668             die "Failed $tot->{bad}/$tot->{tests} test scripts, $pct% okay.".
 669                 "$subpct\n";
 670         }
 671     }
 672
 673     printf("Files=%d, Tests=%d, %s\n",
 674            $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
 675 }
 676
 677
 678 my %Handlers = ();
 679 $Strap->{callback} = sub {
 680     my($self, $line, $type, $totals) = @_;
 681     print $line if $Verbose;
 682
 683     my $meth = $Handlers{$type};
 684     $meth->($self, $line, $type, $totals) if $meth;
 685 };
 686
 687
 688 $Handlers{header} = sub {
 689     my($self, $line, $type, $totals) = @_;
 690
 691     warn "Test header seen more than once!\n" if $self->{_seen_header};
 692
 693     $self->{_seen_header}++;
 694
 695     warn "1..M can only appear at the beginning or end of tests\n"
 696       if $totals->{seen} &&
 697          $totals->{max}  < $totals->{seen};
 698 };
 699
 700 $Handlers{test} = sub {
 701     my($self, $line, $type, $totals) = @_;
 702
 703     my $curr = $totals->{seen};
 704     my $next = $self->{'next'};
 705     my $max  = $totals->{max};
 706     my $detail = $totals->{details}[-1];
 707
 708     if( $detail->{ok} ) {
 709         _print_ml("ok $curr/$max");
 710
 711         if( $detail->{type} eq 'skip' ) {
 712             $totals->{skip_reason} = $detail->{reason}
 713               unless defined $totals->{skip_reason};
 714             $totals->{skip_reason} = 'various reasons'
 715               if $totals->{skip_reason} ne $detail->{reason};
 716         }
 717     }
 718     else {
 719         _print_ml("NOK $curr");
 720     }
 721
 722     if( $curr > $next ) {
 723         print "Test output counter mismatch [test $curr]\n";
 724     }
 725     elsif( $curr < $next ) {
 726         print "Confused test output: test $curr answered after ".
 727               "test ", $next - 1, "\n";
 728     }
 729
 730 };
 731
 732 $Handlers{bailout} = sub {
 733     my($self, $line, $type, $totals) = @_;
 734
 735     die "FAILED--Further testing stopped" .
 736       ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
 737 };
 738
 739
 740 sub _print_ml {
 741     print join '', $ML, @_ if $ML;
 742 }
 743
 744
 745 sub _bonusmsg {
 746     my($tot) = @_;
 747
 748     my $bonusmsg = '';
 749     $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
 750                " UNEXPECTEDLY SUCCEEDED)")
 751         if $tot->{bonus};
 752
 753     if ($tot->{skipped}) {
 754         $bonusmsg .= ", $tot->{skipped} test"
 755                      . ($tot->{skipped} != 1 ? 's' : '');
 756         if ($tot->{sub_skipped}) {
 757             $bonusmsg .= " and $tot->{sub_skipped} subtest"
 758                          . ($tot->{sub_skipped} != 1 ? 's' : '');
 759         }
 760         $bonusmsg .= ' skipped';
 761     }
 762     elsif ($tot->{sub_skipped}) {
 763         $bonusmsg .= ", $tot->{sub_skipped} subtest"
 764                      . ($tot->{sub_skipped} != 1 ? 's' : '')
 765                      . " skipped";
 766     }
 767
 768     return $bonusmsg;
 769 }
 770
 771 # Test program go boom.
 772 sub _dubious_return {
 773     my($test, $tot, $estatus, $wstatus) = @_;
 774     my ($failed, $canon, $percent) = ('??', '??');
 775
 776     printf "$test->{ml}dubious\n\tTest returned status $estatus ".
 777            "(wstat %d, 0x%x)\n",
 778            $wstatus,$wstatus;
 779     print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
 780
 781     if (corestatus($wstatus)) { # until we have a wait module
 782         if ($Have_Devel_Corestack) {
 783             Devel::CoreStack::stack($^X);
 784         } else {
 785             print "\ttest program seems to have generated a core\n";
 786         }
 787     }
 788
 789     $tot->{bad}++;
 790
 791     if ($test->{max}) {
 792         if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
 793             print "\tafter all the subtests completed successfully\n";
 794             $percent = 0;
 795             $failed = 0;        # But we do not set $canon!
 796         }
 797         else {
 798             push @{$test->{failed}}, $test->{'next'}..$test->{max};
 799             $failed = @{$test->{failed}};
 800             (my $txt, $canon) = canonfailed($test->{max},$test->{skipped},@{$test->{failed}});
 801             $percent = 100*(scalar @{$test->{failed}})/$test->{max};
 802             print "DIED. ",$txt;
 803         }
 804     }
 805
 806     return { canon => $canon,  max => $test->{max} || '??',
 807              failed => $failed,
 808              percent => $percent,
 809              estat => $estatus, wstat => $wstatus,
 810            };
 811 }
 812
 813
 814 sub _create_fmts {
 815     my($failedtests) = @_;
 816
 817     my $failed_str = "Failed Test";
 818     my $middle_str = " Stat Wstat Total Fail  Failed  ";
 819     my $list_str = "List of Failed";
 820
 821     # Figure out our longest name string for formatting purposes.
 822     my $max_namelen = length($failed_str);
 823     foreach my $script (keys %$failedtests) {
 824         my $namelen = length $failedtests->{$script}->{name};
 825         $max_namelen = $namelen if $namelen > $max_namelen;
 826     }
 827
 828     my $list_len = $Columns - length($middle_str) - $max_namelen;
 829     if ($list_len < length($list_str)) {
 830         $list_len = length($list_str);
 831         $max_namelen = $Columns - length($middle_str) - $list_len;
 832         if ($max_namelen < length($failed_str)) {
 833             $max_namelen = length($failed_str);
 834             $Columns = $max_namelen + length($middle_str) + $list_len;
 835         }
 836     }
 837
 838     my $fmt_top = "format STDOUT_TOP =\n"
 839                   . sprintf("%-${max_namelen}s", $failed_str)
 840                   . $middle_str
 841                   . $list_str . "\n"
 842                   . "-" x $Columns
 843                   . "\n.\n";
 844
 845     my $fmt = "format STDOUT =\n"
 846               . "@" . "<" x ($max_namelen - 1)
 847               . "  @>> @>>>> @>>>> @>>> ^##.##%  "
 848               . "^" . "<" x ($list_len - 1) . "\n"
 849               . '{ $Curtest->{name}, $Curtest->{estat},'
 850               . '  $Curtest->{wstat}, $Curtest->{max},'
 851               . '  $Curtest->{failed}, $Curtest->{percent},'
 852               . '  $Curtest->{canon}'
 853               . "\n}\n"
 854               . "~~" . " " x ($Columns - $list_len - 2) . "^"
 855               . "<" x ($list_len - 1) . "\n"
 856               . '$Curtest->{canon}'
 857               . "\n.\n";
 858
 859     eval $fmt_top;
 860     die $@ if $@;
 861     eval $fmt;
 862     die $@ if $@;
 863
 864     return($fmt_top, $fmt);
 865 }
 866
 867 {
 868     my $tried_devel_corestack;
 869
 870     sub corestatus {
 871         my($st) = @_;
 872
 873         my $did_core;
 874         eval { # we may not have a WCOREDUMP
 875             local $^W = 0;  # *.ph files are often *very* noisy
 876             require 'wait.ph';
 877             $did_core = WCOREDUMP($st);
 878         };
 879         if( $@ ) {
 880             $did_core = $st & 0200;
 881         }
 882
 883         eval { require Devel::CoreStack; $Have_Devel_Corestack++ }
 884           unless $tried_devel_corestack++;
 885
 886         return $did_core;
 887     }
 888 }
 889
 890 sub canonfailed ($@) {
 891     my($max,$skipped,@failed) = @_;
 892     my %seen;
 893     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
 894     my $failed = @failed;
 895     my @result = ();
 896     my @canon = ();
 897     my $min;
 898     my $last = $min = shift @failed;
 899     my $canon;
 900     if (@failed) {
 901         for (@failed, $failed[-1]) { # don't forget the last one
 902             if ($_ > $last+1 || $_ == $last) {
 903                 if ($min == $last) {
 904                     push @canon, $last;
 905                 } else {
 906                     push @canon, "$min-$last";
 907                 }
 908                 $min = $_;
 909             }
 910             $last = $_;
 911         }
 912         local $" = ", ";
 913         push @result, "FAILED tests @canon\n";
 914         $canon = join ' ', @canon;
 915     } else {
 916         push @result, "FAILED test $last\n";
 917         $canon = $last;
 918     }
 919
 920     push @result, "\tFailed $failed/$max tests, ";
 921     if ($max) {
 922         push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay";
 923     } else {
 924         push @result, "?% okay";
 925     }
 926     my $ender = 's' x ($skipped > 1);
 927     my $good = $max - $failed - $skipped;
 928     if ($skipped) {
 929         my $skipmsg = " (less $skipped skipped test$ender: $good okay, ";
 930         if ($max) {
 931             my $goodper = sprintf("%.2f",100*($good/$max));
 932             $skipmsg .= "$goodper%)";
 933         } else {
 934             $skipmsg .= "?%)";
 935         }
 936         push @result, $skipmsg;
 937     }
 938     push @result, "\n";
 939     my $txt = join "", @result;
 940     ($txt, $canon);
 941 }
 942
 943 =end _private
 944
 945 =back
 946
 947 =cut
 948
 949
 950 1;
 951 __END__
 952
 953
 954 =head1 EXPORT
 955
 956 C<&runtests> is exported by Test::Harness by default.
 957
 958 C<$verbose> and C<$switches> are exported upon request.
 959
 960
 961 =head1 DIAGNOSTICS
 962
 963 =over 4
 964
 965 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 966
 967 If all tests are successful some statistics about the performance are
 968 printed.
 969
 970 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 971
 972 For any single script that has failing subtests statistics like the
 973 above are printed.
 974
 975 =item C<Test returned status %d (wstat %d)>
 976
 977 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
 978 and C<$?> are printed in a message similar to the above.
 979
 980 =item C<Failed 1 test, %.2f%% okay. %s>
 981
 982 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 983
 984 If not all tests were successful, the script dies with one of the
 985 above messages.
 986
 987 =item C<FAILED--Further testing stopped: %s>
 988
 989 If a single subtest decides that further testing will not make sense,
 990 the script dies with this message.
 991
 992 =back
 993
 994 =head1 ENVIRONMENT
 995
 996 =over 4
 997
 998 =item C<HARNESS_ACTIVE>
 999
1000 Harness sets this before executing the individual tests.  This allows
1001 the tests to determine if they are being executed through the harness
1002 or by any other means.
1003
1004 =item C<HARNESS_COLUMNS>
1005
1006 This value will be used for the width of the terminal. If it is not
1007 set then it will default to C<COLUMNS>. If this is not set, it will
1008 default to 80. Note that users of Bourne-sh based shells will need to
1009 C<export COLUMNS> for this module to use that variable.
1010
1011 =item C<HARNESS_COMPILE_TEST>
1012
1013 When true it will make harness attempt to compile the test using
1014 C<perlcc> before running it.
1015
1016 B<NOTE> This currently only works when sitting in the perl source
1017 directory!
1018
1019 =item C<HARNESS_FILELEAK_IN_DIR>
1020
1021 When set to the name of a directory, harness will check after each
1022 test whether new files appeared in that directory, and report them as
1023
1024   LEAKED FILES: scr.tmp 0 my.db
1025
1026 If relative, directory name is with respect to the current directory at
1027 the moment runtests() was called.  Putting absolute path into
1028 C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
1029
1030 =item C<HARNESS_IGNORE_EXITCODE>
1031
1032 Makes harness ignore the exit status of child processes when defined.
1033
1034 =item C<HARNESS_NOTTY>
1035
1036 When set to a true value, forces it to behave as though STDOUT were
1037 not a console.  You may need to set this if you don't want harness to
1038 output more frequent progress messages using carriage returns.  Some
1039 consoles may not handle carriage returns properly (which results in a
1040 somewhat messy output).
1041
1042 =item C<HARNESS_PERL_SWITCHES>
1043
1044 Its value will be prepended to the switches used to invoke perl on
1045 each test.  For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
1046 run all tests with all warnings enabled.
1047
1048 =item C<HARNESS_VERBOSE>
1049
1050 If true, Test::Harness will output the verbose results of running
1051 its tests.  Setting $Test::Harness::verbose will override this.
1052
1053 =back
1054
1055 =head1 EXAMPLE
1056
1057 Here's how Test::Harness tests itself
1058
1059   $ cd ~/src/devel/Test-Harness
1060   $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
1061     $verbose=0; runtests @ARGV;' t/*.t
1062   Using /home/schwern/src/devel/Test-Harness/blib
1063   t/base..............ok
1064   t/nonumbers.........ok
1065   t/ok................ok
1066   t/test-harness......ok
1067   All tests successful.
1068   Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
1069
1070 =head1 SEE ALSO
1071
1072 L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
1073 the underlying timing routines, L<Devel::CoreStack> to generate core
1074 dumps from failed tests and L<Devel::Cover> for test coverage
1075 analysis.
1076
1077 =head1 AUTHORS
1078
1079 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
1080 sure is, that it was inspired by Larry Wall's TEST script that came
1081 with perl distributions for ages. Numerous anonymous contributors
1082 exist.  Andreas Koenig held the torch for many years.
1083
1084 Current maintainer is Michael G Schwern E<lt>schwern@pobox.comE<gt>
1085
1086 =head1 LICENSE
1087
1088 This program is free software; you can redistribute it and/or
1089 modify it under the same terms as Perl itself.
1090
1091 See F<http://www.perl.com/perl/misc/Artistic.html>
1092
1093
1094 =head1 TODO
1095
1096 Provide a way of running tests quietly (ie. no printing) for automated
1097 validation of tests.  This will probably take the form of a version
1098 of runtests() which rather than printing its output returns raw data
1099 on the state of the tests.  (Partially done in Test::Harness::Straps)
1100
1101 Fix HARNESS_COMPILE_TEST without breaking its core usage.
1102
1103 Figure a way to report test names in the failure summary.
1104
1105 Rework the test summary so long test names are not truncated as badly.
1106 (Partially done with new skip test styles)
1107
1108 Deal with VMS's "not \nok 4\n" mistake.
1109
1110 Add option for coverage analysis.
1111
1112 =for _private
1113 Keeping whittling away at _run_all_tests()
1114
1115 =for _private
1116 Clean up how the summary is printed.  Get rid of those damned formats.
1117
1118 =head1 BUGS
1119
1120 HARNESS_COMPILE_TEST currently assumes it's run from the Perl source
1121 directory.
1122
1123 =cut