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