contrib/perl5/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,$skipped,@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/$max 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,$skipped,@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,$skipped,@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";
 334     my $ender = 's' x ($skipped > 1);
 335     my $good = $max - $failed - $skipped;
 336     my $goodper = sprintf("%.2f",100*($good/$max));
 337     push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped;
 338     push @result, "\n";
 339     my $txt = join "", @result;
 340     ($txt, $canon);
 341 }
 342
 343 1;
 344 __END__
 345
 346 =head1 NAME
 347
 348 Test::Harness - run perl standard test scripts with statistics
 349
 350 =head1 SYNOPSIS
 351
 352 use Test::Harness;
 353
 354 runtests(@tests);
 355
 356 =head1 DESCRIPTION
 357
 358 (By using the L<Test> module, you can write test scripts without
 359 knowing the exact output this module expects.  However, if you need to
 360 know the specifics, read on!)
 361
 362 Perl test scripts print to standard output C<"ok N"> for each single
 363 test, where C<N> is an increasing sequence of integers. The first line
 364 output by a standard test script is C<"1..M"> with C<M> being the
 365 number of tests that should be run within the test
 366 script. Test::Harness::runtests(@tests) runs all the testscripts
 367 named as arguments and checks standard output for the expected
 368 C<"ok N"> strings.
 369
 370 After all tests have been performed, runtests() prints some
 371 performance statistics that are computed by the Benchmark module.
 372
 373 =head2 The test script output
 374
 375 Any output from the testscript to standard error is ignored and
 376 bypassed, thus will be seen by the user. Lines written to standard
 377 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
 378 runtests().  All other lines are discarded.
 379
 380 It is tolerated if the test numbers after C<ok> are omitted. In this
 381 case Test::Harness maintains temporarily its own counter until the
 382 script supplies test numbers again. So the following test script
 383
 384     print <<END;
 385     1..6
 386     not ok
 387     ok
 388     not ok
 389     ok
 390     ok
 391     END
 392
 393 will generate
 394
 395     FAILED tests 1, 3, 6
 396     Failed 3/6 tests, 50.00% okay
 397
 398 The global variable $Test::Harness::verbose is exportable and can be
 399 used to let runtests() display the standard output of the script
 400 without altering the behavior otherwise.
 401
 402 The global variable $Test::Harness::switches is exportable and can be
 403 used to set perl command line options used for running the test
 404 script(s). The default value is C<-w>.
 405
 406 If the standard output line contains substring C< # Skip> (with
 407 variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
 408 counted as a skipped test.  If the whole testscript succeeds, the
 409 count of skipped tests is included in the generated output.
 410
 411 =head1 EXPORT
 412
 413 C<&runtests> is exported by Test::Harness per default.
 414
 415 =head1 DIAGNOSTICS
 416
 417 =over 4
 418
 419 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 420
 421 If all tests are successful some statistics about the performance are
 422 printed.
 423
 424 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 425
 426 For any single script that has failing subtests statistics like the
 427 above are printed.
 428
 429 =item C<Test returned status %d (wstat %d)>
 430
 431 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
 432 printed in a message similar to the above.
 433
 434 =item C<Failed 1 test, %.2f%% okay. %s>
 435
 436 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 437
 438 If not all tests were successful, the script dies with one of the
 439 above messages.
 440
 441 =back
 442
 443 =head1 ENVIRONMENT
 444
 445 Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
 446 of child processes.
 447
 448 If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness
 449 will check after each test whether new files appeared in that directory,
 450 and report them as
 451
 452   LEAKED FILES: scr.tmp 0 my.db
 453
 454 If relative, directory name is with respect to the current directory at
 455 the moment runtests() was called.  Putting absolute path into
 456 C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
 457
 458 =head1 SEE ALSO
 459
 460 L<Test> for writing test scripts and also L<Benchmark> for the
 461 underlying timing routines.
 462
 463 =head1 AUTHORS
 464
 465 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 466 sure is, that it was inspired by Larry Wall's TEST script that came
 467 with perl distributions for ages. Numerous anonymous contributors
 468 exist. Current maintainer is Andreas Koenig.
 469
 470 =head1 BUGS
 471
 472 Test::Harness uses $^X to determine the perl binary to run the tests
 473 with. Test scripts running via the shebang (C<#!>) line may not be
 474 portable because $^X is not consistent for shebang scripts across
 475 platforms. This is no problem when Test::Harness is run with an
 476 absolute path to the perl binary or when $^X can be found in the path.
 477
 478 =cut