lib/Test/Harness.pm

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