lib/Test/Harness.pm

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