This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
71c0c1c1ce9d65a2c53858984d4467c344eaffa8
[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.1602";
15
16 $ENV{HARNESS_ACTIVE} = 1;
17
18 # Some experimental versions of OS/2 build have broken $?
19 my $ignore_exitcode = $ENV{HARNESS_IGNORE_EXITCODE};
20
21 my $files_in_dir = $ENV{HARNESS_FILELEAK_IN_DIR};
22
23 my $tests_skipped = 0;
24 my $subtests_skipped = 0;
25
26 @ISA=('Exporter');
27 @EXPORT= qw(&runtests);
28 @EXPORT_OK= qw($verbose $switches);
29
30 format STDOUT_TOP =
31 Failed Test  Status Wstat Total Fail  Failed  List of failed
32 -------------------------------------------------------------------------------
33 .
34
35 format STDOUT =
36 @<<<<<<<<<<<<<< @>> @>>>> @>>>> @>>> ^##.##%  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
37 { $curtest->{name},
38                 $curtest->{estat},
39                     $curtest->{wstat},
40                           $curtest->{max},
41                                 $curtest->{failed},
42                                      $curtest->{percent},
43                                               $curtest->{canon}
44 }
45 ~~                                            ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
46                                               $curtest->{canon}
47 .
48
49
50 $verbose = 0;
51 $switches = "-w";
52
53 sub globdir { opendir DIRH, shift; my @f = readdir DIRH; closedir DIRH; @f }
54
55 sub runtests {
56     my(@tests) = @_;
57     local($|) = 1;
58     my($test,$te,$ok,$next,$max,$pct,$totok,$totbonus,@failed,%failedtests);
59     my $totmax = 0;
60     my $files = 0;
61     my $bad = 0;
62     my $good = 0;
63     my $total = @tests;
64
65     # pass -I flags to children
66     my $old5lib = $ENV{PERL5LIB};
67     local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC);
68
69     if ($^O eq 'VMS') { $switches =~ s/-(\S*[A-Z]\S*)/"-$1"/g }
70
71     my @dir_files = globdir $files_in_dir if defined $files_in_dir;
72     my $t_start = new Benchmark;
73     while ($test = shift(@tests)) {
74         $te = $test;
75         chop($te);
76         if ($^O eq 'VMS') { $te =~ s/^.*\.t\./[.t./; }
77         print "$te" . '.' x (20 - length($te));
78         my $fh = new FileHandle;
79         $fh->open($test) or print "can't open $test. $!\n";
80         my $first = <$fh>;
81         my $s = $switches;
82         $s .= q[ "-T"] if $first =~ /^#!.*\bperl.*-\w*T/;
83         $fh->close or print "can't close $test. $!\n";
84         my $cmd = ($ENV{'COMPILE_TEST'})? 
85 "./perl -I../lib ../utils/perlcc $test -run 2>> ./compilelog |" 
86                                                                                                                         :  "$^X $s $test|";
87         $cmd = "MCR $cmd" if $^O eq 'VMS';
88         $fh->open($cmd) or print "can't run $test. $!\n";
89         $ok = $next = $max = 0;
90         @failed = ();
91         my %todo = ();
92         my $bonus = 0;
93         my $skipped = 0;
94         while (<$fh>) {
95             if( $verbose ){
96                 print $_;
97             }
98             if (/^1\.\.([0-9]+) todo([\d\s]+)\;/) {
99                 $max = $1;
100                 for (split(/\s+/, $2)) { $todo{$_} = 1; }
101                 $totmax += $max;
102                 $files++;
103                 $next = 1;
104             } elsif (/^1\.\.([0-9]+)/) {
105                 $max = $1;
106                 $totmax += $max;
107                 $files++;
108                 $next = 1;
109             } elsif ($max && /^(not\s+)?ok\b/) {
110                 my $this = $next;
111                 if (/^not ok\s*(\d*)/){
112                     $this = $1 if $1 > 0;
113                     if (!$todo{$this}) {
114                         push @failed, $this;
115                     } else {
116                         $ok++;
117                         $totok++;
118                     }
119                 } elsif (/^ok\s*(\d*)(\s*\#\s*[Ss]kip)?/) {
120                     $this = $1 if $1 > 0;
121                     $ok++;
122                     $totok++;
123                     $skipped++ if defined $2;
124                     $bonus++, $totbonus++ if $todo{$this};
125                 }
126                 if ($this > $next) {
127                     # warn "Test output counter mismatch [test $this]\n";
128                     # no need to warn probably
129                     push @failed, $next..$this-1;
130                 } elsif ($this < $next) {
131                     #we have seen more "ok" lines than the number suggests
132                     warn "Confused test output: test $this answered after test ", $next-1, "\n";
133                     $next = $this;
134                 }
135                 $next = $this + 1;
136             }
137         }
138         $fh->close; # must close to reap child resource values
139         my $wstatus = $ignore_exitcode ? 0 : $?;        # Can trust $? ?
140         my $estatus;
141         $estatus = ($^O eq 'VMS'
142                        ? eval 'use vmsish "status"; $estatus = $?'
143                        : $wstatus >> 8);
144         if ($wstatus) {
145             my ($failed, $canon, $percent) = ('??', '??');
146             printf "dubious\n\tTest returned status $estatus (wstat %d, 0x%x)\n",
147                     $wstatus,$wstatus;
148             print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
149             if (corestatus($wstatus)) { # until we have a wait module
150                 if ($have_devel_corestack) {
151                     Devel::CoreStack::stack($^X);
152                 } else {
153                     print "\ttest program seems to have generated a core\n";
154                 }
155             }
156             $bad++;
157             if ($max) {
158               if ($next == $max + 1 and not @failed) {
159                 print "\tafter all the subtests completed successfully\n";
160                 $percent = 0;
161                 $failed = 0;    # But we do not set $canon!
162               } else {
163                 push @failed, $next..$max;
164                 $failed = @failed;
165                 (my $txt, $canon) = canonfailed($max,$skipped,@failed);
166                 $percent = 100*(scalar @failed)/$max;
167                 print "DIED. ",$txt;
168               }
169             }
170             $failedtests{$test} = { canon => $canon,  max => $max || '??',
171                                     failed => $failed, 
172                                     name => $test, percent => $percent,
173                                     estat => $estatus, wstat => $wstatus,
174                                   };
175         } elsif ($ok == $max && $next == $max+1) {
176             if ($max and $skipped + $bonus) {
177                 my @msg;
178                 push(@msg, "$skipped/$max subtest".($skipped>1?'s':'')." skipped")
179                     if $skipped;
180                 push(@msg, "$bonus subtest".($bonus>1?'s':'').
181                      " unexpectedly succeeded")
182                     if $bonus;
183                 print "ok, ".join(', ', @msg)."\n";
184             } elsif ($max) {
185                 print "ok\n";
186             } else {
187                 print "skipping test on this platform\n";
188                 $tests_skipped++;
189             }
190             $good++;
191         } elsif ($max) {
192             if ($next <= $max) {
193                 push @failed, $next..$max;
194             }
195             if (@failed) {
196                 my ($txt, $canon) = canonfailed($max,$skipped,@failed);
197                 print $txt;
198                 $failedtests{$test} = { canon => $canon,  max => $max,
199                                         failed => scalar @failed,
200                                         name => $test, percent => 100*(scalar @failed)/$max,
201                                         estat => '', wstat => '',
202                                       };
203             } else {
204                 print "Don't know which tests failed: got $ok ok, expected $max\n";
205                 $failedtests{$test} = { canon => '??',  max => $max,
206                                         failed => '??', 
207                                         name => $test, percent => undef,
208                                         estat => '', wstat => '',
209                                       };
210             }
211             $bad++;
212         } elsif ($next == 0) {
213             print "FAILED before any test output arrived\n";
214             $bad++;
215             $failedtests{$test} = { canon => '??',  max => '??',
216                                     failed => '??',
217                                     name => $test, percent => undef,
218                                     estat => '', wstat => '',
219                                   };
220         }
221         $subtests_skipped += $skipped;
222         if (defined $files_in_dir) {
223             my @new_dir_files = globdir $files_in_dir;
224             if (@new_dir_files != @dir_files) {
225                 my %f;
226                 @f{@new_dir_files} = (1) x @new_dir_files;
227                 delete @f{@dir_files};
228                 my @f = sort keys %f;
229                 print "LEAKED FILES: @f\n";
230                 @dir_files = @new_dir_files;
231             }
232         }
233     }
234     my $t_total = timediff(new Benchmark, $t_start);
235     
236     if ($^O eq 'VMS') {
237         if (defined $old5lib) {
238             $ENV{PERL5LIB} = $old5lib;
239         } else {
240             delete $ENV{PERL5LIB};
241         }
242     }
243     my $bonusmsg = '';
244     $bonusmsg = (" ($totbonus subtest".($totbonus>1?'s':'').
245                " UNEXPECTEDLY SUCCEEDED)")
246         if $totbonus;
247     if ($tests_skipped) {
248         $bonusmsg .= ", $tests_skipped test" . ($tests_skipped != 1 ? 's' : '');
249         if ($subtests_skipped) {
250             $bonusmsg .= " and $subtests_skipped subtest"
251                          . ($subtests_skipped != 1 ? 's' : '');
252         }
253         $bonusmsg .= ' skipped';
254     }
255     elsif ($subtests_skipped) {
256         $bonusmsg .= ", $subtests_skipped subtest"
257                      . ($subtests_skipped != 1 ? 's' : '')
258                      . " skipped";
259     }
260     if ($bad == 0 && $totmax) {
261         print "All tests successful$bonusmsg.\n";
262     } elsif ($total==0){
263         die "FAILED--no tests were run for some reason.\n";
264     } elsif ($totmax==0) {
265         my $blurb = $total==1 ? "script" : "scripts";
266         die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
267     } else {
268         $pct = sprintf("%.2f", $good / $total * 100);
269         my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
270         $totmax - $totok, $totmax, 100*$totok/$totmax;
271         my $script;
272         for $script (sort keys %failedtests) {
273           $curtest = $failedtests{$script};
274           write;
275         }
276         if ($bad) {
277             $bonusmsg =~ s/^,\s*//;
278             print "$bonusmsg.\n" if $bonusmsg;
279             die "Failed $bad/$total test scripts, $pct% okay.$subpct\n";
280         }
281     }
282     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
283
284     return ($bad == 0 && $totmax) ;
285 }
286
287 my $tried_devel_corestack;
288 sub corestatus {
289     my($st) = @_;
290     my($ret);
291
292     eval {require 'wait.ph'};
293     if ($@) {
294       SWITCH: {
295             $ret = ($st & 0200); # Tim says, this is for 90%
296         }
297     } else {
298         $ret = WCOREDUMP($st);
299     }
300
301     eval { require Devel::CoreStack; $have_devel_corestack++ } 
302       unless $tried_devel_corestack++;
303
304     $ret;
305 }
306
307 sub canonfailed ($@) {
308     my($max,$skipped,@failed) = @_;
309     my %seen;
310     @failed = sort {$a <=> $b} grep !$seen{$_}++, @failed;
311     my $failed = @failed;
312     my @result = ();
313     my @canon = ();
314     my $min;
315     my $last = $min = shift @failed;
316     my $canon;
317     if (@failed) {
318         for (@failed, $failed[-1]) { # don't forget the last one
319             if ($_ > $last+1 || $_ == $last) {
320                 if ($min == $last) {
321                     push @canon, $last;
322                 } else {
323                     push @canon, "$min-$last";
324                 }
325                 $min = $_;
326             }
327             $last = $_;
328         }
329         local $" = ", ";
330         push @result, "FAILED tests @canon\n";
331         $canon = "@canon";
332     } else {
333         push @result, "FAILED test $last\n";
334         $canon = $last;
335     }
336
337     push @result, "\tFailed $failed/$max tests, ";
338     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay";
339     my $ender = 's' x ($skipped > 1);
340     my $good = $max - $failed - $skipped;
341     my $goodper = sprintf("%.2f",100*($good/$max));
342     push @result, " (-$skipped skipped test$ender: $good okay, $goodper%)" if $skipped;
343     push @result, "\n";
344     my $txt = join "", @result;
345     ($txt, $canon);
346 }
347
348 1;
349 __END__
350
351 =head1 NAME
352
353 Test::Harness - run perl standard test scripts with statistics
354
355 =head1 SYNOPSIS
356
357 use Test::Harness;
358
359 runtests(@tests);
360
361 =head1 DESCRIPTION
362
363 (By using the L<Test> module, you can write test scripts without
364 knowing the exact output this module expects.  However, if you need to
365 know the specifics, read on!)
366
367 Perl test scripts print to standard output C<"ok N"> for each single
368 test, where C<N> is an increasing sequence of integers. The first line
369 output by a standard test script is C<"1..M"> with C<M> being the
370 number of tests that should be run within the test
371 script. Test::Harness::runtests(@tests) runs all the testscripts
372 named as arguments and checks standard output for the expected
373 C<"ok N"> strings.
374
375 After all tests have been performed, runtests() prints some
376 performance statistics that are computed by the Benchmark module.
377
378 =head2 The test script output
379
380 Any output from the testscript to standard error is ignored and
381 bypassed, thus will be seen by the user. Lines written to standard
382 output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
383 runtests().  All other lines are discarded.
384
385 It is tolerated if the test numbers after C<ok> are omitted. In this
386 case Test::Harness maintains temporarily its own counter until the
387 script supplies test numbers again. So the following test script
388
389     print <<END;
390     1..6
391     not ok
392     ok
393     not ok
394     ok
395     ok
396     END
397
398 will generate 
399
400     FAILED tests 1, 3, 6
401     Failed 3/6 tests, 50.00% okay
402
403 The global variable $Test::Harness::verbose is exportable and can be
404 used to let runtests() display the standard output of the script
405 without altering the behavior otherwise.
406
407 The global variable $Test::Harness::switches is exportable and can be
408 used to set perl command line options used for running the test
409 script(s). The default value is C<-w>.
410
411 If the standard output line contains substring C< # Skip> (with
412 variations in spacing and case) after C<ok> or C<ok NUMBER>, it is
413 counted as a skipped test.  If the whole testscript succeeds, the
414 count of skipped tests is included in the generated output.
415
416 =head1 EXPORT
417
418 C<&runtests> is exported by Test::Harness per default.
419
420 =head1 DIAGNOSTICS
421
422 =over 4
423
424 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
425
426 If all tests are successful some statistics about the performance are
427 printed.
428
429 =item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
430
431 For any single script that has failing subtests statistics like the
432 above are printed.
433
434 =item C<Test returned status %d (wstat %d)>
435
436 Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8> and C<$?> are
437 printed in a message similar to the above.
438
439 =item C<Failed 1 test, %.2f%% okay. %s>
440
441 =item C<Failed %d/%d tests, %.2f%% okay. %s>
442
443 If not all tests were successful, the script dies with one of the
444 above messages.
445
446 =back
447
448 =head1 ENVIRONMENT
449
450 Setting C<HARNESS_IGNORE_EXITCODE> makes harness ignore the exit status
451 of child processes.
452
453 If C<HARNESS_FILELEAK_IN_DIR> is set to the name of a directory, harness
454 will check after each test whether new files appeared in that directory,
455 and report them as
456
457   LEAKED FILES: scr.tmp 0 my.db
458
459 If relative, directory name is with respect to the current directory at
460 the moment runtests() was called.  Putting absolute path into 
461 C<HARNESS_FILELEAK_IN_DIR> may give more predicatable results.
462
463 Harness sets C<HARNESS_ACTIVE> before executing the individual tests.
464 This allows the tests to determine if they are being executed through the
465 harness or by any other means.
466
467 =head1 SEE ALSO
468
469 L<Test> for writing test scripts and also L<Benchmark> for the
470 underlying timing routines.
471
472 =head1 AUTHORS
473
474 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
475 sure is, that it was inspired by Larry Wall's TEST script that came
476 with perl distributions for ages. Numerous anonymous contributors
477 exist. Current maintainer is Andreas Koenig.
478
479 =head1 BUGS
480
481 Test::Harness uses $^X to determine the perl binary to run the tests
482 with. Test scripts running via the shebang (C<#!>) line may not be
483 portable because $^X is not consistent for shebang scripts across
484 platforms. This is no problem when Test::Harness is run with an
485 absolute path to the perl binary or when $^X can be found in the path.
486
487 =cut