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