Commit | Line | Data |
a0d0e21e |
1 | package Test::Harness; |
2 | |
3 | use Exporter; |
4 | use Benchmark; |
4633a7c4 |
5 | use Config; |
c07a80fd |
6 | require 5.002; |
4633a7c4 |
7 | |
c07a80fd |
8 | $VERSION = $VERSION = "1.02"; |
4633a7c4 |
9 | |
c07a80fd |
10 | @ISA=('Exporter'); |
cb1a09d0 |
11 | @EXPORT= qw(&runtests); |
a0d0e21e |
12 | @EXPORT_OK= qw($verbose $switches); |
13 | |
c07a80fd |
14 | |
15 | $Test::Harness::verbose = 0; |
16 | $Test::Harness::switches = "-w"; |
a0d0e21e |
17 | |
18 | sub runtests { |
19 | my(@tests) = @_; |
20 | local($|) = 1; |
c07a80fd |
21 | my($test,$te,$ok,$next,$max,$totmax, $files,$pct,@failed); |
a0d0e21e |
22 | my $bad = 0; |
23 | my $good = 0; |
24 | my $total = @tests; |
c07a80fd |
25 | local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children |
a0d0e21e |
26 | |
27 | my $t_start = new Benchmark; |
28 | while ($test = shift(@tests)) { |
c07a80fd |
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 | } |
a0d0e21e |
79 | } |
80 | my $t_total = timediff(new Benchmark, $t_start); |
c07a80fd |
81 | |
a0d0e21e |
82 | if ($bad == 0) { |
c07a80fd |
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"; |
a0d0e21e |
120 | } else { |
c07a80fd |
121 | push @result, "FAILED test $last\n"; |
a0d0e21e |
122 | } |
c07a80fd |
123 | |
124 | push @result, "\tFailed $failed/$max tests, "; |
125 | push @result, sprintf("%.2f",100*(1-$failed/$max)), "% okay\n"; |
126 | join "", @result; |
a0d0e21e |
127 | } |
128 | |
129 | 1; |
cb1a09d0 |
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 | |
c07a80fd |
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. |
cb1a09d0 |
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 |