lib/Test/Harness.pm

   1 package Test::Harness;
   2
   3 BEGIN {require 5.002;}
   4 use Exporter;
   5 use Benchmark;
   6 use Config;
   7 use FileHandle;
   8 use strict;
   9
  10 use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
  11             @ISA @EXPORT @EXPORT_OK);
  12 $have_devel_corestack = 0;
  13
  14 $VERSION = "1.1602";
  15
  16 # Some experimental versions of OS/2 build have broken $?
  17 my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
  18
  19 my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
  20
  21 my $tests_skipped = 0;
  22 my $subtests_skipped = 0;
  23
  24 @ISA=('Exporter');
  25 @EXPORT= qw(&runtests);
  26 @EXPORT_OK= qw($verbose $switches);
  27
  28 format STDOUT_TOP =
  29 Failed Test  Status Wstat Total Fail  Failed  List of failed
  30 -------------------------------------------------------------------------------
  31 .
  32
  33 format STDOUT =
  34 @<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##%  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  35 { $curtest->{name},
  36                 $curtest->{estat},
  37                     $curtest->{wstat},
  38                           $curtest->{max},
  39                                 $curtest->{failed},
  40                                      $curtest->{percent},
  41                                               $curtest->{canon}
  42 }
  43 ~~                                            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  44                                               $curtest->{canon}
  45 .
  46
  47
  48 $verbose = 0;
  49 $switches = "-w";
  50
  51 sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
  52
  53 sub runtests {
  54     my(@tests) = @_;
  55     local($|) = 1;
  56     my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests);
  57     my $totmax = 0;
  58     my $files = 0;
  59     my $bad = 0;
  60     my $good = 0;
  61     my $total = @tests;
  62
  63     # pass -I flags to children
  64     my $old5lib = $ENV{PERL5LIB};
  65     local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);
  66
  67     if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }
  68
  69     my @dir_files = globdir $files_in_dir if defined $files_in_dir;
  70     my $t_start = new Benchmark;
  71     while ($test = shift(@tests)) {
  72         $te = $test;
  73         chop($te);
  74         if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; }
  75         print "$te" . '.' x (20 - length($te));
  76         my $fh = new FileHandle;
  77         $fh->open($test) or print "can't open $test. $!\n";
  78         my $first = <$fh>;
  79         my $s = $switches;
  80         $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
  81         $fh->close or print "can't close $test. $!\n";
  82         my $cmd = ($ENV{'COMPILE_TEST'})?
  83 "./perl -I../lib ../utils/perlcc $test -run -verbose dcf -log ./compilelog |"
  84                                                                                                                         :  "$^X $s $test|";
  85         $cmd = "MCR $cmd" if $^O eq 'VMS';
  86         $fh->open($cmd) or print "can't run $test. $!\n";
  87         $ok = $next = $max = 0;
  88         @failed = ();
  89         my %todo = ();
  90         my $bonus = 0;
  91         my $skipped = 0;
  92         while (<$fh>) {
  93             if( $verbose ){
  94                 print $_;
  95             }
  96             if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
  97                 $max = $1;
  98                 for (split(/\s+/, $2)) { $todo{$_} = 1; }
  99                 $totmax += $max;
 100                 $files++;
 101                 $next = 1;
 102             } elsif (/^1\.\.([0-9]+)/) {
 103                 $max = $1;
 104                 $totmax += $max;
 105                 $files++;
 106                 $next = 1;
 107             } elsif ($max && /^(not\s+)?ok\b/) {
 108                 my $this = $next;
 109                 if (/^not ok\s*(\d*)/){
 110                     $this = $1 if $1 > 0;
 111                     if (!$todo{$this}) {
 112                         push @failed, $this;
 113                     } else {
 114                         $ok++;
 115                         $totok++;
 116                     }
 117                 } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) {
 118                     $this = $1 if $1 > 0;
 119                     $ok++;
 120                     $totok++;
 121                     $skipped++ if defined $2;
 122                     $bonus++, $totbonus++ if $todo{$this};
 123                 }
 124                 if ($this > $next) {
 125                     # warn "Test output counter mismatch [test $this]\n";
 126                     # no need to warn probably
 127                     push @failed, $next..$this-1;
 128                 } elsif ($this < $next) {
 129                     #we have seen more "ok" lines than the number suggests
 130                     warn "Confused test output: test $this answered after test ", $next-1, "\n";
 131                     $next = $this;
 132                 }
 133                 $next = $this + 1;
 134             }
 135         }
 136         $fh->close; # must close to reap child resource values
 137         my $wstatus = $ignore_exitcode ? 0 : $?;        # Can trust $? ?
 138         my $estatus;
 139         $estatus = ($^O eq 'VMS'
 140                        ? eval 'use vmsish "status"; $estatus = $?'
 141                        : $wstatus >> 8);
 142         if ($wstatus) {
 143             my ($failed, $canon, $percent) = ('??', '??');
 144             printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
 145                     $wstatus,$wstatus;
 146             print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
 147             if (corestatus($wstatus)) { # until we have a wait module
 148                 if ($have_devel_corestack) {
 149                     Devel::CoreStack::stack($^X);
 150                 } else {
 151                     print "\ttest program seems to have generated a core\n";
 152                 }
 153             }
 154             $bad++;
 155             if ($max) {
 156               if ($next == $max + 1 and not @failed) {
 157                 print "\tafter all the subtests completed successfully\n";
 158                 $percent = 0;
 159                 $failed = 0;    # But we do not set $canon!
 160               } else {
 161                 push @failed, $next..$max;
 162                 $failed = @failed;
 163                 (my $txt, $canon) = canonfailed($max,@failed);
 164                 $percent = 100*(scalar @failed)/$max;
 165                 print "DIED. ",$txt;
 166               }
 167             }
 168             $failedtests{$test} = { canon => $canon,  max => $max || '??',
 169                                     failed => $failed,
 170                                     name => $test, percent => $percent,
 171                                     estat => $estatus, wstat => $wstatus,
 172                                   };
 173         } elsif ($ok == $max && $next == $max+1) {
 174             if ($max and $skipped + $bonus) {
 175                 my @msg;
 176                 push(@msg, "$skipped subtest".($skipped>1?'s':'')." skipped")
 177                     if $skipped;
 178                 push(@msg, "$bonus subtest".($bonus>1?'s':'').
 179                      " unexpectedly succeeded")
 180                     if $bonus;
 181                 print "ok, ".join(', ', @msg)."\n";
 182             } elsif ($max) {
 183                 print "ok\n";
 184             } else {
 185                 print "skipping test on this platform\n";
 186                 $tests_skipped++;
 187             }
 188             $good++;
 189         } elsif ($max) {
 190             if ($next <= $max) {
 191                 push @failed, $next..$max;
 192             }
 193             if (@failed) {
 194                 my ($txt, $canon) = canonfailed($max,@failed);
 195                 print $txt;
 196                 $failedtests{$test} = { canon => $canon,  max => $max,
 197                                         failed => scalar @failed,
 198                                         name => $test, percent => 100*(scalar @failed)/$max,
 199                                         estat => '', wstat => '',
 200                                       };
 201             } else {
 202                 print "Don't know which tests failed: got $ok ok, expected $max\n";
 203                 $failedtests{$test} = { canon => '??',  max => $max,
 204                                         failed => '??',
 205                                         name => $test, percent => undef,
 206                                         estat => '', wstat => '',
 207                                       };
 208             }
 209             $bad++;
 210         } elsif ($next == 0) {
 211             print "FAILED before any test output arrived\n";
 212             $bad++;
 213             $failedtests{$test} = { canon => '??',  max => '??',
 214                                     failed => '??',
 215                                     name => $test, percent => undef,
 216                                     estat => '', wstat => '',
 217                                   };
 218         }
 219         $subtests_skipped += $skipped;
 220         if (defined $files_in_dir) {
 221             my @new_dir_files = globdir $files_in_dir;
 222             if (@new_dir_files != @dir_files) {
 223                 my %f;
 224                 @f{@new_dir_files} = (1) x @new_dir_files;
 225                 delete @f{@dir_files};
 226                 my @f = sort keys %f;
 227                 print "LEAKED FILES: @f\n";
 228                 @dir_files = @new_dir_files;
 229             }
 230         }
 231     }
 232     my $t_total = timediff(new Benchmark, $t_start);
 233
 234     if ($^O eq 'VMS') {
 235         if (defined $old5lib) {
 236             $ENV{PERL5LIB} = $old5lib;
 237         } else {
 238             delete $ENV{PERL5LIB};
 239         }
 240     }
 241     my $bonusmsg = '';
 242     $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
 243                " UNEXPECTEDLY SUCCEEDED)")
 244         if $totbonus;
 245     if ($tests_skipped) {
 246         $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '') .
 247                         ' skipped';
 248     }
 249     if ($subtests_skipped) {
 250         $bonusmsg .= ($tests_skipped ? ', plus ' : ', ').
 251                         "$subtests_skipped subtest"
 252                         . ($subtests_skipped != 1 ? 's' : '') .
 253                         " skipped";
 254     }
 255     if ($bad == 0 && $totmax) {
 256         print "All tests successful$bonusmsg.\n";
 257     } elsif ($total==0){
 258         die "FAILED--no tests were run for some reason.\n";
 259     } elsif ($totmax==0) {
 260         my $blurb = $total==1 ? "script" : "scripts";
 261         die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
 262     } else {
 263         $pct = sprintf("%.2f", $good / $total * 100);
 264         my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
 265         $totmax - $totok, $totmax, 100*$totok/$totmax;
 266         my $script;
 267         for $script (sort keys %failedtests) {
 268           $curtest = $failedtests{$script};
 269           write;
 270         }
 271         if ($bad) {
 272             $bonusmsg =~ s/^,\s*//;
 273             print "$bonusmsg.\n" if $bonusmsg;
 274             die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
 275         }
 276     }
 277     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
 278
 279     return ($bad == 0 && $totmax) ;
 280 }
 281
 282 my $tried_devel_corestack;
 283 sub corestatus {
 284     my($st) = @_;
 285     my($ret);
 286
 287     eval {require 'wait.ph'};
 288     if ($@) {
 289       SWITCH: {
 290             $ret = ($st & 0200); # Tim says, this is for 90%
 291         }
 292     } else {
 293         $ret = WCOREDUMP($st);
 294     }
 295
 296     eval { require Devel::CoreStack; $have_devel_corestack++ }
 297       unless $tried_devel_corestack++;
 298
 299     $ret;
 300 }
 301
 302 sub canonfailed ($@) {
 303     my($max,@failed) = @_;
 304     my %seen;
 305     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
 306     my $failed = @failed;
 307     my @result = ();
 308     my @canon = ();
 309     my $min;
 310     my $last = $min = shift @failed;
 311     my $canon;
 312     if (@failed) {
 313         for (@failed, $failed[-1]) { # don't forget the last one
 314             if ($_ > $last+1 || $_ == $last) {
 315                 if ($min == $last) {
 316                     push @canon, $last;
 317                 } else {
 318                     push @canon, "$min-$last";
 319                 }
 320                 $min = $_;
 321             }
 322             $last = $_;
 323         }
 324         local $" = ", ";
 325         push @result, "FAILED tests @canon\n";
 326         $canon = "@canon";
 327     } else {
 328         push @result, "FAILED test $last\n";
 329         $canon = $last;
 330     }
 331
 332     push @result, "\tFailed $failed/$max tests, ";
 333     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
 334     my $txt = join "", @result;
 335     ($txt, $canon);
 336 }
 337
 338 1;
 339 __END__
 340
 341 =head1 NAME
 342
 343 Test::Harness - run perl standard test scripts with statistics
 344
 345 =head1 SYNOPSIS
 346
 347 use Test::Harness;
 348
 349 runtests(@tests);
 350
 351 =head1 DESCRIPTION
 352
 353 (By using the L<Test> module, you can write test scripts without
 354 knowing the exact output this module expects.  However, if you need to
 355 know the specifics, read on!)
 356
 357 Perl test scripts print to standard output C<"ok N"> for each single
 358 test, where C<N> is an increasing sequence of integers. The first line
 359 output by a standard test script is C<"1..M"> with C<M> being the
 360 number of tests that should be run within the test
 361 script. Test::Harness::runtests(@tests) runs all the testscripts
 362 named as arguments and checks standard output for the expected
 363 C<"ok N"> strings.
 364
 365 After all tests have been performed, runtests() prints some
 366 performance statistics that are computed by the Benchmark module.
 367
 368 =head2 The test script output
 369
 370 Any output from the testscript to standard error is ignored and
 371 bypassed, thus will be seen by the user. Lines written to standard
 372 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
 373 runtests().  All other lines are discarded.
 374
 375 It is tolerated if the test numbers after C<ok> are omitted. In this
 376 case Test::Harness maintains temporarily its own counter until the
 377 script supplies test numbers again. So the following test script
 378
 379     print <<END;
 380     1..6
 381     not ok
 382     ok
 383     not ok
 384     ok
 385     ok
 386     END
 387
 388 will generate
 389
 390     FAILED tests 1, 3, 6
 391     Failed 3/6 tests, 50.00% okay
 392
 393 The global variable $Test::Harness::verbose is exportable and can be
 394 used to let runtests() display the standard output of the script
 395 without altering the behavior otherwise.
 396
 397 The global variable $Test::Harness::switches is exportable and can be
 398 used to set perl command line options used for running the test
 399 script(s). The default value is C<-w>.
 400
 401 If the standard output line contains substring C< # Skip> (with
 402 variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
 403 counted as a skipped test.  If the whole testscript succeeds, the
 404 count of skipped tests is included in the generated output.
 405
 406 =head1 EXPORT
 407
 408 C<&runtests> is exported by Test::Harness per default.
 409
 410 =head1 DIAGNOSTICS
 411
 412 =over 4
 413
 414 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 415
 416 If all tests are successful some statistics about the performance are
 417 printed.
 418
 419 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 420
 421 For any single script that has failing subtests statistics like the
 422 above are printed.
 423
 424 =item C<Test returned status %d (wstat %d)>
 425
 426 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
 427 printed in a message similar to the above.
 428
 429 =item C<Failed 1 test, %.2f%% okay. %s>
 430
 431 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 432
 433 If not all tests were successful, the script dies with one of the
 434 above messages.
 435
 436 =back
 437
 438 =head1 ENVIRONMENT
 439
 440 Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
 441 of child processes.
 442
 443 If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness
 444 will check after each test whether new files appeared in that directory,
 445 and report them as
 446
 447   LEAKED FILES: scr.tmp 0 my.db
 448
 449 If relative, directory name is with respect to the current directory at
 450 the moment runtests() was called.  Putting absolute path into
 451 C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
 452
 453 =head1 SEE ALSO
 454
 455 L<Test> for writing test scripts and also L<Benchmark> for the
 456 underlying timing routines.
 457
 458 =head1 AUTHORS
 459
 460 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 461 sure is, that it was inspired by Larry Wall's TEST script that came
 462 with perl distributions for ages. Numerous anonymous contributors
 463 exist. Current maintainer is Andreas Koenig.
 464
 465 =head1 BUGS
 466
 467 Test::Harness uses $^X to determine the perl binary to run the tests
 468 with. Test scripts running via the shebang (C<#!>) line may not be
 469 portable because $^X is not consistent for shebang scripts across
 470 platforms. This is no problem when Test::Harness is run with an
 471 absolute path to the perl binary or when $^X can be found in the path.
 472
 473 =cut