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.1502";
  15
  16 @ISA=('Exporter');
  17 @EXPORT= qw(&runtests);
  18 @EXPORT_OK= qw($verbose $switches);
  19
  20 format STDOUT_TOP =
  21 Failed Test  Status Wstat Total Fail  Failed  List of failed
  22 -------------------------------------------------------------------------------
  23 .
  24
  25 format STDOUT =
  26 @<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##%  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  27 { $curtest->{name},
  28                 $curtest->{estat},
  29                     $curtest->{wstat},
  30                           $curtest->{max},
  31                                 $curtest->{failed},
  32                                      $curtest->{percent},
  33                                               $curtest->{canon}
  34 }
  35 ~~                                            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  36                                               $curtest->{canon}
  37 .
  38
  39
  40 $verbose = 0;
  41 $switches = "-w";
  42
  43 sub runtests {
  44     my(@tests) = @_;
  45     local($|) = 1;
  46     my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests);
  47     my $totmax = 0;
  48     my $files = 0;
  49     my $bad = 0;
  50     my $good = 0;
  51     my $total = @tests;
  52
  53     # pass -I flags to children
  54     my $old5lib = $ENV{PERL5LIB};
  55     local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);
  56
  57     if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }
  58
  59     my $t_start = new Benchmark;
  60     while ($test = shift(@tests)) {
  61         $te = $test;
  62         chop($te);
  63         if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; }
  64         print "$te" . '.' x (20 - length($te));
  65         my $fh = new FileHandle;
  66         $fh->open($test) or print "can't open $test. $!\n";
  67         my $first = <$fh>;
  68         my $s = $switches;
  69         $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
  70         $fh->close or print "can't close $test. $!\n";
  71         my $cmd = "$^X $s $test|";
  72         $cmd = "MCR $cmd" if $^O eq 'VMS';
  73         $fh->open($cmd) or print "can't run $test. $!\n";
  74         $ok = $next = $max = 0;
  75         @failed = ();
  76         while (<$fh>) {
  77             if( $verbose ){
  78                 print $_;
  79             }
  80             if (/^1\.\.([0-9]+)/) {
  81                 $max = $1;
  82                 $totmax += $max;
  83                 $files++;
  84                 $next = 1;
  85             } elsif ($max && /^(not\s+)?ok\b/) {
  86                 my $this = $next;
  87                 if (/^not ok\s*(\d*)/){
  88                     $this = $1 if $1 > 0;
  89                     push @failed, $this;
  90                 } elsif (/^ok\s*(\d*)/) {
  91                     $this = $1 if $1 > 0;
  92                     $ok++;
  93                     $totok++;
  94                 }
  95                 if ($this > $next) {
  96                     # warn "Test output counter mismatch [test $this]\n";
  97                     # no need to warn probably
  98                     push @failed, $next..$this-1;
  99                 } elsif ($this < $next) {
 100                     #we have seen more "ok" lines than the number suggests
 101                     warn "Confused test output: test $this answered after test ", $next-1, "\n";
 102                     $next = $this;
 103                 }
 104                 $next = $this + 1;
 105             }
 106         }
 107         $fh->close; # must close to reap child resource values
 108         my $wstatus = $?;
 109         my $estatus;
 110         $estatus = ($^O eq 'VMS'
 111                        ? eval 'use vmsish "status"; $estatus = $?'
 112                        : $wstatus >> 8);
 113         if ($wstatus) {
 114             my ($failed, $canon, $percent) = ('??', '??');
 115             printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
 116                     $wstatus,$wstatus;
 117             print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
 118             if (corestatus($wstatus)) { # until we have a wait module
 119                 if ($have_devel_corestack) {
 120                     Devel::CoreStack::stack($^X);
 121                 } else {
 122                     print "\ttest program seems to have generated a core\n";
 123                 }
 124             }
 125             $bad++;
 126             if ($max) {
 127               if ($next == $max + 1 and not @failed) {
 128                 print "\tafter all the subtests completed successfully\n";
 129                 $percent = 0;
 130                 $failed = 0;    # But we do not set $canon!
 131               } else {
 132                 push @failed, $next..$max;
 133                 $failed = @failed;
 134                 (my $txt, $canon) = canonfailed($max,@failed);
 135                 $percent = 100*(scalar @failed)/$max;
 136                 print "DIED. ",$txt;
 137               }
 138             }
 139             $failedtests{$test} = { canon => $canon,  max => $max || '??',
 140                                     failed => $failed,
 141                                     name => $test, percent => $percent,
 142                                     estat => $estatus, wstat => $wstatus,
 143                                   };
 144         } elsif ($ok == $max && $next == $max+1) {
 145             if ($max) {
 146                 print "ok\n";
 147             } else {
 148                 print "skipping test on this platform\n";
 149             }
 150             $good++;
 151         } elsif ($max) {
 152             if ($next <= $max) {
 153                 push @failed, $next..$max;
 154             }
 155             if (@failed) {
 156                 my ($txt, $canon) = canonfailed($max,@failed);
 157                 print $txt;
 158                 $failedtests{$test} = { canon => $canon,  max => $max,
 159                                         failed => scalar @failed,
 160                                         name => $test, percent => 100*(scalar @failed)/$max,
 161                                         estat => '', wstat => '',
 162                                       };
 163             } else {
 164                 print "Don't know which tests failed: got $ok ok, expected $max\n";
 165                 $failedtests{$test} = { canon => '??',  max => $max,
 166                                         failed => '??',
 167                                         name => $test, percent => undef,
 168                                         estat => '', wstat => '',
 169                                       };
 170             }
 171             $bad++;
 172         } elsif ($next == 0) {
 173             print "FAILED before any test output arrived\n";
 174             $bad++;
 175             $failedtests{$test} = { canon => '??',  max => '??',
 176                                     failed => '??',
 177                                     name => $test, percent => undef,
 178                                     estat => '', wstat => '',
 179                                   };
 180         }
 181     }
 182     my $t_total = timediff(new Benchmark, $t_start);
 183
 184     if ($^O eq 'VMS') {
 185         if (defined $old5lib) {
 186             $ENV{PERL5LIB} = $old5lib;
 187         } else {
 188             delete $ENV{PERL5LIB};
 189         }
 190     }
 191     if ($bad == 0 && $totmax) {
 192             print "All tests successful.\n";
 193     } elsif ($total==0){
 194         die "FAILED--no tests were run for some reason.\n";
 195     } elsif ($totmax==0) {
 196         my $blurb = $total==1 ? "script" : "scripts";
 197         die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
 198     } else {
 199         $pct = sprintf("%.2f", $good / $total * 100);
 200         my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
 201         $totmax - $totok, $totmax, 100*$totok/$totmax;
 202         my $script;
 203         for $script (sort keys %failedtests) {
 204           $curtest = $failedtests{$script};
 205           write;
 206         }
 207         if ($bad) {
 208             die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
 209         }
 210     }
 211     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
 212
 213     return ($bad == 0 && $totmax) ;
 214 }
 215
 216 my $tried_devel_corestack;
 217 sub corestatus {
 218     my($st) = @_;
 219     my($ret);
 220
 221     eval {require 'wait.ph'};
 222     if ($@) {
 223       SWITCH: {
 224             $ret = ($st & 0200); # Tim says, this is for 90%
 225         }
 226     } else {
 227         $ret = WCOREDUMP($st);
 228     }
 229
 230     eval { require Devel::CoreStack; $have_devel_corestack++ }
 231       unless $tried_devel_corestack++;
 232
 233     $ret;
 234 }
 235
 236 sub canonfailed ($@) {
 237     my($max,@failed) = @_;
 238     my %seen;
 239     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
 240     my $failed = @failed;
 241     my @result = ();
 242     my @canon = ();
 243     my $min;
 244     my $last = $min = shift @failed;
 245     my $canon;
 246     if (@failed) {
 247         for (@failed, $failed[-1]) { # don't forget the last one
 248             if ($_ > $last+1 || $_ == $last) {
 249                 if ($min == $last) {
 250                     push @canon, $last;
 251                 } else {
 252                     push @canon, "$min-$last";
 253                 }
 254                 $min = $_;
 255             }
 256             $last = $_;
 257         }
 258         local $" = ", ";
 259         push @result, "FAILED tests @canon\n";
 260         $canon = "@canon";
 261     } else {
 262         push @result, "FAILED test $last\n";
 263         $canon = $last;
 264     }
 265
 266     push @result, "\tFailed $failed/$max tests, ";
 267     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
 268     my $txt = join "", @result;
 269     ($txt, $canon);
 270 }
 271
 272 1;
 273 __END__
 274
 275 =head1 NAME
 276
 277 Test::Harness - run perl standard test scripts with statistics
 278
 279 =head1 SYNOPSIS
 280
 281 use Test::Harness;
 282
 283 runtests(@tests);
 284
 285 =head1 DESCRIPTION
 286
 287 Perl test scripts print to standard output C<"ok N"> for each single
 288 test, where C<N> is an increasing sequence of integers. The first line
 289 output by a standard test script is C<"1..M"> with C<M> being the
 290 number of tests that should be run within the test
 291 script. Test::Harness::runtests(@tests) runs all the testscripts
 292 named as arguments and checks standard output for the expected
 293 C<"ok N"> strings.
 294
 295 After all tests have been performed, runtests() prints some
 296 performance statistics that are computed by the Benchmark module.
 297
 298 =head2 The test script output
 299
 300 Any output from the testscript to standard error is ignored and
 301 bypassed, thus will be seen by the user. Lines written to standard
 302 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
 303 runtests().  All other lines are discarded.
 304
 305 It is tolerated if the test numbers after C<ok> are omitted. In this
 306 case Test::Harness maintains temporarily its own counter until the
 307 script supplies test numbers again. So the following test script
 308
 309     print <<END;
 310     1..6
 311     not ok
 312     ok
 313     not ok
 314     ok
 315     ok
 316     END
 317
 318 will generate
 319
 320     FAILED tests 1, 3, 6
 321     Failed 3/6 tests, 50.00% okay
 322
 323 The global variable $Test::Harness::verbose is exportable and can be
 324 used to let runtests() display the standard output of the script
 325 without altering the behavior otherwise.
 326
 327 The global variable $Test::Harness::switches is exportable and can be
 328 used to set perl command line options used for running the test
 329 script(s). The default value is C<-w>.
 330
 331 =head1 EXPORT
 332
 333 C<&runtests> is exported by Test::Harness per default.
 334
 335 =head1 DIAGNOSTICS
 336
 337 =over 4
 338
 339 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
 340
 341 If all tests are successful some statistics about the performance are
 342 printed.
 343
 344 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
 345
 346 For any single script that has failing subtests statistics like the
 347 above are printed.
 348
 349 =item C<Test returned status %d (wstat %d)>
 350
 351 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
 352 printed in a message similar to the above.
 353
 354 =item C<Failed 1 test, %.2f%% okay. %s>
 355
 356 =item C<Failed %d/%d tests, %.2f%% okay. %s>
 357
 358 If not all tests were successful, the script dies with one of the
 359 above messages.
 360
 361 =back
 362
 363 =head1 SEE ALSO
 364
 365 See L<Benchmark> for the underlying timing routines.
 366
 367 =head1 AUTHORS
 368
 369 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
 370 sure is, that it was inspired by Larry Wall's TEST script that came
 371 with perl distributions for ages. Numerous anonymous contributors
 372 exist. Current maintainer is Andreas Koenig.
 373
 374 =head1 BUGS
 375
 376 Test::Harness uses $^X to determine the perl binary to run the tests
 377 with. Test scripts running via the shebang (C<#!>) line may not be
 378 portable because $^X is not consistent for shebang scripts across
 379 platforms. This is no problem when Test::Harness is run with an
 380 absolute path to the perl binary or when $^X can be found in the path.
 381
 382 =cut