lib/Test/Harness.pm

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