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