perl5.002beta3
[perl.git] / lib / Test / Harness.pm
1 package Test::Harness;
2
3 use Exporter;
4 use Benchmark;
5 use Config;
6 require 5.002;
7
8 $VERSION = $VERSION = "1.02";
9
10 @ISA=('Exporter');
11 @EXPORT= qw(&runtests);
12 @EXPORT_OK= qw($verbose $switches);
13
14
15 $Test::Harness::verbose = 0;
16 $Test::Harness::switches = "-w";
17
18 sub runtests {
19     my(@tests) = @_;
20     local($|) = 1;
21     my($test,$te,$ok,$next,$max,$totmax, $files,$pct,@failed);
22     my $bad = 0;
23     my $good = 0;
24     my $total = @tests;
25     local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
26
27     my $t_start = new Benchmark;
28     while ($test = shift(@tests)) {
29         $te = $test;
30         chop($te);
31         print "$te" . '.' x (20 - length($te));
32         my $fh = "RESULTS";
33         open($fh,"$^X $Test::Harness::switches $test|") || (print "can't run. $!\n");
34         $ok = $next = $max = 0;
35         @failed = ();
36         while (<$fh>) {
37             if( $Test::Harness::verbose ){
38                 print $_;
39             }
40             unless (/^\#/) {
41                 if (/^1\.\.([0-9]+)/) {
42                     $max = $1;
43                     $totmax += $max;
44                     $files++;
45                     $next = 1;
46                 } elsif ($max) {
47                     if (/^not ok ([0-9]*)/){
48                         push @failed, $next;
49                     } elsif (/^ok (.*)/ && $1 == $next) {
50                         $ok++;
51                     }
52                     $next = $1 + 1;
53                 }
54             }
55         }
56         close($fh); # must close to reap child resource values
57         my $wstatus = $?;
58         my $estatus = $wstatus >> 8;
59         $next-- if $next;
60         if ($ok == $max && $next == $max && ! $wstatus) {
61             print "ok\n";
62             $good++;
63         } else {
64             if (@failed) {
65                 print canonfailed($max,@failed);
66             } else {
67                 if ($next == 0) {
68                     print "FAILED before any test output arrived\n";
69                 } else {
70                     print canonfailed($max,$next+1..$max);
71                 }
72             }
73             if ($wstatus) {
74                 print "\tTest returned status $estatus (wstat $wstatus)\n";
75             }
76             $bad++;
77             $_ = $test;
78         }
79     }
80     my $t_total = timediff(new Benchmark, $t_start);
81     
82     if ($bad == 0) {
83         if ($ok) {
84             print "All tests successful.\n";
85         } else {
86             die "FAILED--no tests were run for some reason.\n";
87         }
88     } else {
89         $pct = sprintf("%.2f", $good / $total * 100);
90         if ($bad == 1) {
91             die "Failed 1 test script, $pct% okay.\n";
92         } else {
93             die "Failed $bad/$total test scripts, $pct% okay.\n";
94         }
95     }
96     printf("Files=%d,  Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
97 }
98
99 sub canonfailed ($@) {
100     my($max,@failed) = @_;
101     my $failed = @failed;
102     my @result = ();
103     my @canon = ();
104     my $min;
105     my $last = $min = shift @failed;
106     if (@failed) {
107         for (@failed, $failed[-1]) { # don't forget the last one
108             if ($_ > $last+1 || $_ == $last) {
109                 if ($min == $last) {
110                     push @canon, $last;
111                 } else {
112                     push @canon, "$min-$last";
113                 }
114                 $min = $_;
115             }
116             $last = $_;
117         }
118         local $" = ", ";
119         push @result, "FAILED tests @canon\n";
120     } else {
121         push @result, "FAILED test $last\n";
122     }
123
124     push @result, "\tFailed $failed/$max tests, ";
125     push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n";
126     join "", @result;
127 }
128
129 1;
130 __END__
131
132 =head1 NAME
133
134 Test::Harness - run perl standard test scripts with statistics
135
136 =head1 SYNOPSIS
137
138 use Test::Harness;
139
140 runtests(@tests);
141
142 =head1 DESCRIPTION
143
144 Perl test scripts print to standard output C<"ok N"> for each single
145 test, where C<N> is an increasing sequence of integers. The first line
146 output by a standard test scxript is C<"1..M"> with C<M> being the
147 number of tests that should be run within the test
148 script. Test::Harness::runscripts(@tests) runs all the testscripts
149 named as arguments and checks standard output for the expected
150 C<"ok N"> strings.
151
152 After all tests have been performed, runscripts() prints some
153 performance statistics that are computed by the Benchmark module.
154
155 =head1 EXPORT
156
157 C<&runscripts> is exported by Test::Harness per default.
158
159 =head1 DIAGNOSTICS
160
161 =over 4
162
163 =item C<All tests successful.\nFiles=%d,  Tests=%d, %s>
164
165 If all tests are successful some statistics about the performance are
166 printed.
167
168 =item C<Failed 1 test, $pct% okay.>
169
170 =item C<Failed %d/%d tests, %.2f%% okay.>
171
172 If not all tests were successful, the script dies with one of the
173 above messages.
174
175 =back
176
177 =head1 SEE ALSO
178
179 See L<Benchmark> for the underlying timing routines.
180
181 =head1 AUTHORS
182
183 Either Tim Bunce or Andreas Koenig, we don't know. What we know for
184 sure is, that it was inspired by Larry Wall's TEST script that came
185 with perl distributions for ages. Current maintainer is Andreas
186 Koenig.
187
188 =head1 BUGS
189
190 Test::Harness uses $^X to determine the perl binary to run the tests
191 with. Test scripts running via the shebang (C<#!>) line may not be portable
192 because $^X is not consistent for shebang scripts across
193 platforms. This is no problem when Test::Harness is run with an
194 absolute path to the perl binary.
195
196 =cut