This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Refresh Test::Harness to 1.15
[perl5.git] / 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