Commit | Line | Data |
a0d0e21e |
1 | package Test::Harness; |
2 | |
3c87ea76 |
3 | require 5.00405; |
b965d173 |
4 | |
760ac839 |
5 | use strict; |
6 | |
b965d173 |
7 | use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); |
8 | use constant IS_VMS => ( $^O eq 'VMS' ); |
9 | |
10 | use TAP::Harness (); |
11 | use TAP::Parser::Aggregator (); |
12 | use TAP::Parser::Source::Perl (); |
ca09b021 |
13 | |
b965d173 |
14 | use Config; |
15 | use Exporter; |
16 | |
17 | # TODO: Emulate at least some of these |
e4fc8a1e |
18 | use vars qw( |
b965d173 |
19 | $VERSION |
20 | @ISA @EXPORT @EXPORT_OK |
21 | $Verbose $Switches $Debug |
22 | $verbose $switches $debug |
23 | $Columns |
24 | $Directives |
25 | $Timer |
26 | $Strap |
27 | $has_time_hires |
e4fc8a1e |
28 | ); |
29 | |
b965d173 |
30 | # $ML $Last_ML_Print |
31 | |
43ef773b |
32 | BEGIN { |
5b1ebecd |
33 | eval q{use Time::HiRes 'time'}; |
43ef773b |
34 | $has_time_hires = !$@; |
35 | } |
36 | |
e4fc8a1e |
37 | =head1 NAME |
38 | |
39 | Test::Harness - Run Perl standard test scripts with statistics |
40 | |
41 | =head1 VERSION |
42 | |
69f36734 |
43 | Version 3.06 |
e4fc8a1e |
44 | |
45 | =cut |
46 | |
69f36734 |
47 | $VERSION = '3.06'; |
4633a7c4 |
48 | |
9c5c68c8 |
49 | # Backwards compatibility for exportable variable names. |
5c0604c3 |
50 | *verbose = *Verbose; |
51 | *switches = *Switches; |
e4fc8a1e |
52 | *debug = *Debug; |
9c5c68c8 |
53 | |
b965d173 |
54 | $ENV{HARNESS_ACTIVE} = 1; |
c0c1f8c2 |
55 | $ENV{HARNESS_VERSION} = $VERSION; |
f19ae7a7 |
56 | |
13287dd5 |
57 | END { |
b965d173 |
58 | |
13287dd5 |
59 | # For VMS. |
60 | delete $ENV{HARNESS_ACTIVE}; |
c0c1f8c2 |
61 | delete $ENV{HARNESS_VERSION}; |
13287dd5 |
62 | } |
63 | |
b965d173 |
64 | @ISA = ('Exporter'); |
9c5c68c8 |
65 | @EXPORT = qw(&runtests); |
20f9f807 |
66 | @EXPORT_OK = qw(&execute_tests $verbose $switches); |
4633a7c4 |
67 | |
b965d173 |
68 | $Verbose = $ENV{HARNESS_VERBOSE} || 0; |
69 | $Debug = $ENV{HARNESS_DEBUG} || 0; |
5b1ebecd |
70 | $Switches = '-w'; |
b965d173 |
71 | $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80; |
72 | $Columns--; # Some shells have trouble with a full line of text. |
73 | $Timer = $ENV{HARNESS_TIMER} || 0; |
b82fa0b7 |
74 | |
b82fa0b7 |
75 | =head1 SYNOPSIS |
76 | |
77 | use Test::Harness; |
78 | |
79 | runtests(@test_files); |
80 | |
81 | =head1 DESCRIPTION |
a0d0e21e |
82 | |
b965d173 |
83 | Although, for historical reasons, the L<Test::Harness> distribution |
84 | takes its name from this module it now exists only to provide |
85 | L<TAP::Harness> with an interface that is somewhat backwards compatible |
86 | with L<Test::Harness> 2.xx. If you're writing new code consider using |
87 | L<TAP::Harness> directly instead. |
b82fa0b7 |
88 | |
b965d173 |
89 | Emulation is provided for C<runtests> and C<execute_tests> but the |
90 | pluggable 'Straps' interface that previous versions of L<Test::Harness> |
91 | supported is not reproduced here. Straps is now available as a stand |
92 | alone module: L<Test::Harness::Straps>. |
b82fa0b7 |
93 | |
b965d173 |
94 | See L<TAP::Parser> for the main documentation for this distribution. |
13287dd5 |
95 | |
b965d173 |
96 | =head1 FUNCTIONS |
13287dd5 |
97 | |
b965d173 |
98 | The following functions are available. |
13287dd5 |
99 | |
b965d173 |
100 | =head2 runtests( @test_files ) |
13287dd5 |
101 | |
b965d173 |
102 | This runs all the given I<@test_files> and divines whether they passed |
103 | or failed based on their output to STDOUT (details above). It prints |
104 | out each individual test which failed along with a summary report and |
105 | a how long it all took. |
13287dd5 |
106 | |
b965d173 |
107 | It returns true if everything was ok. Otherwise it will C<die()> with |
108 | one of the messages in the DIAGNOSTICS section. |
13287dd5 |
109 | |
b965d173 |
110 | =cut |
13287dd5 |
111 | |
b965d173 |
112 | sub _has_taint { |
113 | my $test = shift; |
114 | return TAP::Parser::Source::Perl->get_taint( |
115 | TAP::Parser::Source::Perl->shebang($test) ); |
116 | } |
13287dd5 |
117 | |
b965d173 |
118 | sub _aggregate { |
119 | my ( $harness, $aggregate, @tests ) = @_; |
13287dd5 |
120 | |
b965d173 |
121 | # Don't propagate to our children |
122 | local $ENV{HARNESS_OPTIONS}; |
13287dd5 |
123 | |
b965d173 |
124 | if (IS_VMS) { |
43ef773b |
125 | |
b965d173 |
126 | # Jiggery pokery doesn't appear to work on VMS - so disable it |
127 | # pending investigation. |
128 | $harness->aggregate_tests( $aggregate, @tests ); |
129 | } |
130 | else { |
131 | my $path_sep = $Config{path_sep}; |
132 | my $path_pat = qr{$path_sep}; |
133 | my @extra_inc = _filtered_inc(); |
134 | |
135 | # Supply -I switches in taint mode |
136 | $harness->callback( |
137 | parser_args => sub { |
138 | my ( $args, $test ) = @_; |
139 | if ( _has_taint( $test->[0] ) ) { |
140 | push @{ $args->{switches} }, map {"-I$_"} _filtered_inc(); |
141 | } |
142 | } |
143 | ); |
43ef773b |
144 | |
b965d173 |
145 | my $previous = $ENV{PERL5LIB}; |
146 | local $ENV{PERL5LIB}; |
13287dd5 |
147 | |
b965d173 |
148 | if ($previous) { |
149 | push @extra_inc, split( $path_pat, $previous ); |
150 | } |
13287dd5 |
151 | |
b965d173 |
152 | if (@extra_inc) { |
153 | $ENV{PERL5LIB} = join( $path_sep, @extra_inc ); |
154 | } |
b82fa0b7 |
155 | |
b965d173 |
156 | $harness->aggregate_tests( $aggregate, @tests ); |
157 | } |
158 | } |
b82fa0b7 |
159 | |
b965d173 |
160 | sub runtests { |
161 | my @tests = @_; |
b82fa0b7 |
162 | |
b965d173 |
163 | # shield against -l |
164 | local ( $\, $, ); |
b82fa0b7 |
165 | |
b965d173 |
166 | my $harness = _new_harness(); |
167 | my $aggregate = TAP::Parser::Aggregator->new(); |
b82fa0b7 |
168 | |
b965d173 |
169 | _aggregate( $harness, $aggregate, @tests ); |
b82fa0b7 |
170 | |
b965d173 |
171 | $harness->formatter->summary($aggregate); |
b82fa0b7 |
172 | |
b965d173 |
173 | my $total = $aggregate->total; |
174 | my $passed = $aggregate->passed; |
175 | my $failed = $aggregate->failed; |
b82fa0b7 |
176 | |
b965d173 |
177 | my @parsers = $aggregate->parsers; |
b82fa0b7 |
178 | |
b965d173 |
179 | my $num_bad = 0; |
180 | for my $parser (@parsers) { |
181 | $num_bad++ if $parser->has_problems; |
182 | } |
b82fa0b7 |
183 | |
b965d173 |
184 | die(sprintf( |
185 | "Failed %d/%d test programs. %d/%d subtests failed.\n", |
186 | $num_bad, scalar @parsers, $failed, $total |
187 | ) |
188 | ) if $num_bad; |
b82fa0b7 |
189 | |
b965d173 |
190 | return $total && $total == $passed; |
191 | } |
b82fa0b7 |
192 | |
b965d173 |
193 | sub _canon { |
194 | my @list = sort { $a <=> $b } @_; |
195 | my @ranges = (); |
196 | my $count = scalar @list; |
197 | my $pos = 0; |
198 | |
199 | while ( $pos < $count ) { |
200 | my $end = $pos + 1; |
201 | $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1; |
202 | push @ranges, ( $end == $pos + 1 ) |
203 | ? $list[$pos] |
204 | : join( '-', $list[$pos], $list[ $end - 1 ] ); |
205 | $pos = $end; |
206 | } |
b82fa0b7 |
207 | |
b965d173 |
208 | return join( ' ', @ranges ); |
209 | } |
b82fa0b7 |
210 | |
b965d173 |
211 | sub _new_harness { |
b82fa0b7 |
212 | |
b965d173 |
213 | if ( defined( my $env_sw = $ENV{HARNESS_PERL_SWITCHES} ) ) { |
214 | $Switches .= ' ' . $env_sw if ( length($env_sw) ); |
215 | } |
b82fa0b7 |
216 | |
b965d173 |
217 | # This is a bit crufty. The switches have all been joined into a |
218 | # single string so we have to try and recover them. |
219 | my ( @lib, @switches ); |
220 | for my $opt ( split( /\s+(?=-)/, $Switches ) ) { |
221 | if ( $opt =~ /^ -I (.*) $ /x ) { |
222 | push @lib, $1; |
223 | } |
224 | else { |
225 | push @switches, $opt; |
226 | } |
227 | } |
b82fa0b7 |
228 | |
b965d173 |
229 | # Do things the old way on VMS... |
230 | push @lib, _filtered_inc() if IS_VMS; |
231 | |
232 | my $args = { |
233 | timer => $Timer, |
234 | directives => $Directives, |
235 | lib => \@lib, |
236 | switches => \@switches, |
237 | verbosity => $Verbose, |
238 | }; |
239 | |
240 | if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) { |
241 | for my $opt ( split /:/, $env_opt ) { |
242 | if ( $opt =~ /^j(\d*)$/ ) { |
243 | $args->{jobs} = $1 || 9; |
244 | } |
245 | elsif ( $opt eq 'f' ) { |
246 | $args->{fork} = 1; |
247 | } |
248 | else { |
249 | die "Unknown HARNESS_OPTIONS item: $opt\n"; |
250 | } |
251 | } |
252 | } |
b82fa0b7 |
253 | |
b965d173 |
254 | return TAP::Harness->new($args); |
255 | } |
b82fa0b7 |
256 | |
b965d173 |
257 | # Get the parts of @INC which are changed from the stock list AND |
258 | # preserve reordering of stock directories. |
259 | sub _filtered_inc { |
260 | my @inc = grep { !ref } @INC; #28567 |
b82fa0b7 |
261 | |
b965d173 |
262 | if (IS_VMS) { |
b82fa0b7 |
263 | |
b965d173 |
264 | # VMS has a 255-byte limit on the length of %ENV entries, so |
265 | # toss the ones that involve perl_root, the install location |
266 | @inc = grep !/perl_root/i, @inc; |
b82fa0b7 |
267 | |
b965d173 |
268 | } |
269 | elsif (IS_WIN32) { |
b82fa0b7 |
270 | |
b965d173 |
271 | # Lose any trailing backslashes in the Win32 paths |
272 | s/[\\\/+]$// foreach @inc; |
273 | } |
b82fa0b7 |
274 | |
b965d173 |
275 | my @default_inc = _default_inc(); |
b82fa0b7 |
276 | |
b965d173 |
277 | my @new_inc; |
278 | my %seen; |
279 | for my $dir (@inc) { |
280 | next if $seen{$dir}++; |
17a79f5b |
281 | |
b965d173 |
282 | if ( $dir eq ( $default_inc[0] || '' ) ) { |
283 | shift @default_inc; |
284 | } |
285 | else { |
286 | push @new_inc, $dir; |
287 | } |
9c5c68c8 |
288 | |
b965d173 |
289 | shift @default_inc while @default_inc and $seen{ $default_inc[0] }; |
290 | } |
b82fa0b7 |
291 | |
b965d173 |
292 | return @new_inc; |
293 | } |
9c5c68c8 |
294 | |
b965d173 |
295 | { |
b82fa0b7 |
296 | |
b965d173 |
297 | # Cache this to avoid repeatedly shelling out to Perl. |
298 | my @inc; |
b82fa0b7 |
299 | |
b965d173 |
300 | sub _default_inc { |
301 | return @inc if @inc; |
302 | my $perl = $ENV{HARNESS_PERL} || $^X; |
303 | chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` ); |
304 | return @inc; |
d1ef75db |
305 | } |
b82fa0b7 |
306 | } |
307 | |
b965d173 |
308 | sub _check_sequence { |
309 | my @list = @_; |
310 | my $prev; |
311 | while ( my $next = shift @list ) { |
312 | return if defined $prev && $next <= $prev; |
313 | $prev = $next; |
314 | } |
2fe373ce |
315 | |
b965d173 |
316 | return 1; |
2fe373ce |
317 | } |
318 | |
b965d173 |
319 | sub execute_tests { |
320 | my %args = @_; |
b82fa0b7 |
321 | |
b965d173 |
322 | # TODO: Handle out option |
323 | |
324 | my $harness = _new_harness(); |
325 | my $aggregate = TAP::Parser::Aggregator->new(); |
326 | |
327 | my %tot = ( |
328 | bonus => 0, |
329 | max => 0, |
330 | ok => 0, |
331 | bad => 0, |
332 | good => 0, |
333 | files => 0, |
334 | tests => 0, |
335 | sub_skipped => 0, |
336 | todo => 0, |
337 | skipped => 0, |
338 | bench => undef, |
339 | ); |
340 | |
341 | # Install a callback so we get to see any plans the |
342 | #Â harness executes. |
343 | $harness->callback( |
344 | made_parser => sub { |
345 | my $parser = shift; |
346 | $parser->callback( |
347 | plan => sub { |
348 | my $plan = shift; |
349 | if ( $plan->directive eq 'SKIP' ) { |
350 | $tot{skipped}++; |
351 | } |
352 | } |
353 | ); |
354 | } |
355 | ); |
356 | |
357 | _aggregate( $harness, $aggregate, @{ $args{tests} } ); |
358 | |
359 | $tot{bench} = $aggregate->elapsed; |
360 | my @tests = $aggregate->descriptions; |
361 | |
362 | # TODO: Work out the circumstances under which the files |
363 | # and tests totals can differ. |
364 | $tot{files} = $tot{tests} = scalar @tests; |
365 | |
366 | my %failedtests = (); |
367 | my %todo_passed = (); |
368 | |
369 | for my $test (@tests) { |
370 | my ($parser) = $aggregate->parsers($test); |
371 | |
372 | my @failed = $parser->failed; |
373 | |
374 | my $wstat = $parser->wait; |
375 | my $estat = $parser->exit; |
376 | my $planned = $parser->tests_planned; |
377 | my @errors = $parser->parse_errors; |
378 | my $passed = $parser->passed; |
379 | my $actual_passed = $parser->actual_passed; |
380 | |
381 | my $ok_seq = _check_sequence( $parser->actual_passed ); |
382 | |
383 | # Duplicate exit, wait status semantics of old version |
384 | $estat ||= '' unless $wstat; |
385 | $wstat ||= ''; |
386 | |
387 | $tot{max} += ( $planned || 0 ); |
388 | $tot{bonus} += $parser->todo_passed; |
389 | $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed; |
390 | $tot{sub_skipped} += $parser->skipped; |
391 | $tot{todo} += $parser->todo; |
392 | |
393 | if ( @failed || $estat || @errors ) { |
394 | $tot{bad}++; |
395 | |
396 | my $huh_planned = $planned ? undef : '??'; |
397 | my $huh_errors = $ok_seq ? undef : '??'; |
398 | |
399 | $failedtests{$test} = { |
400 | 'canon' => $huh_planned |
401 | || $huh_errors |
402 | || _canon(@failed) |
403 | || '??', |
404 | 'estat' => $estat, |
405 | 'failed' => $huh_planned |
406 | || $huh_errors |
407 | || scalar @failed, |
408 | 'max' => $huh_planned || $planned, |
409 | 'name' => $test, |
410 | 'wstat' => $wstat |
411 | }; |
412 | } |
413 | else { |
414 | $tot{good}++; |
415 | } |
b82fa0b7 |
416 | |
b965d173 |
417 | my @todo = $parser->todo_passed; |
418 | if (@todo) { |
419 | $todo_passed{$test} = { |
420 | 'canon' => _canon(@todo), |
421 | 'estat' => $estat, |
422 | 'failed' => scalar @todo, |
423 | 'max' => scalar $parser->todo, |
424 | 'name' => $test, |
425 | 'wstat' => $wstat |
426 | }; |
427 | } |
428 | } |
b82fa0b7 |
429 | |
b965d173 |
430 | return ( \%tot, \%failedtests, \%todo_passed ); |
9c5c68c8 |
431 | } |
432 | |
20f9f807 |
433 | =head2 execute_tests( tests => \@test_files, out => \*FH ) |
b82fa0b7 |
434 | |
20f9f807 |
435 | Runs all the given C<@test_files> (just like C<runtests()>) but |
436 | doesn't generate the final report. During testing, progress |
437 | information will be written to the currently selected output |
438 | filehandle (usually C<STDOUT>), or to the filehandle given by the |
439 | C<out> parameter. The I<out> is optional. |
b82fa0b7 |
440 | |
20f9f807 |
441 | Returns a list of two values, C<$total> and C<$failed>, describing the |
442 | results. C<$total> is a hash ref summary of all the tests run. Its |
443 | keys and values are this: |
b82fa0b7 |
444 | |
445 | bonus Number of individual todo tests unexpectedly passed |
446 | max Number of individual tests ran |
447 | ok Number of individual tests passed |
448 | sub_skipped Number of individual tests skipped |
2fe373ce |
449 | todo Number of individual todo tests |
b82fa0b7 |
450 | |
451 | files Number of test files ran |
452 | good Number of test files passed |
453 | bad Number of test files failed |
454 | tests Number of test files originally given |
455 | skipped Number of test files skipped |
456 | |
e4fc8a1e |
457 | If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've |
458 | got a successful test. |
b82fa0b7 |
459 | |
20f9f807 |
460 | C<$failed> is a hash ref of all the test scripts that failed. Each key |
b82fa0b7 |
461 | is the name of a test script, each value is another hash representing |
462 | how that script failed. Its keys are these: |
9c5c68c8 |
463 | |
b82fa0b7 |
464 | name Name of the test which failed |
465 | estat Script's exit value |
466 | wstat Script's wait status |
467 | max Number of individual tests |
468 | failed Number which failed |
b82fa0b7 |
469 | canon List of tests which failed (as string). |
470 | |
e4fc8a1e |
471 | C<$failed> should be empty if everything passed. |
b82fa0b7 |
472 | |
b82fa0b7 |
473 | =cut |
474 | |
b82fa0b7 |
475 | 1; |
476 | __END__ |
9c5c68c8 |
477 | |
cb1a09d0 |
478 | =head1 EXPORT |
479 | |
b965d173 |
480 | C<&runtests> is exported by C<Test::Harness> by default. |
cb1a09d0 |
481 | |
20f9f807 |
482 | C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are |
483 | exported upon request. |
9c5c68c8 |
484 | |
b965d173 |
485 | =head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS |
c0c1f8c2 |
486 | |
b965d173 |
487 | C<Test::Harness> sets these before executing the individual tests. |
9b0ceca9 |
488 | |
37ce32a7 |
489 | =over 4 |
490 | |
356733da |
491 | =item C<HARNESS_ACTIVE> |
37ce32a7 |
492 | |
c0c1f8c2 |
493 | This is set to a true value. It allows the tests to determine if they |
494 | are being executed through the harness or by any other means. |
495 | |
496 | =item C<HARNESS_VERSION> |
497 | |
b965d173 |
498 | This is the version of C<Test::Harness>. |
c0c1f8c2 |
499 | |
500 | =back |
501 | |
502 | =head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS |
503 | |
504 | =over 4 |
37ce32a7 |
505 | |
ea5423ed |
506 | =item C<HARNESS_TIMER> |
507 | |
508 | Setting this to true will make the harness display the number of |
509 | milliseconds each test took. You can also use F<prove>'s C<--timer> |
510 | switch. |
511 | |
356733da |
512 | =item C<HARNESS_VERBOSE> |
37ce32a7 |
513 | |
b965d173 |
514 | If true, C<Test::Harness> will output the verbose results of running |
5b1ebecd |
515 | its tests. Setting C<$Test::Harness::verbose> will override this, |
516 | or you can use the C<-v> switch in the F<prove> utility. |
517 | |
b965d173 |
518 | =item C<HARNESS_OPTIONS> |
5b1ebecd |
519 | |
b965d173 |
520 | Provide additional options to the harness. Currently supported options are: |
5b1ebecd |
521 | |
b965d173 |
522 | =over |
5b1ebecd |
523 | |
b965d173 |
524 | =item C<< j<n> >> |
5b1ebecd |
525 | |
b965d173 |
526 | Run <n> (default 9) parallel jobs. |
b82fa0b7 |
527 | |
b965d173 |
528 | =item C<< f >> |
37ce32a7 |
529 | |
b965d173 |
530 | Use forked parallelism. |
b82fa0b7 |
531 | |
b965d173 |
532 | =back |
cf2ab31a |
533 | |
b965d173 |
534 | Multiple options may be separated by colons: |
cf2ab31a |
535 | |
b965d173 |
536 | HARNESS_OPTIONS=j9:f make test |
cf2ab31a |
537 | |
b965d173 |
538 | =back |
cf2ab31a |
539 | |
b965d173 |
540 | =head1 SEE ALSO |
b82fa0b7 |
541 | |
b965d173 |
542 | L<TAP::Harness> |
cb1a09d0 |
543 | |
544 | =head1 BUGS |
545 | |
20f9f807 |
546 | Please report any bugs or feature requests to |
547 | C<bug-test-harness at rt.cpan.org>, or through the web interface at |
b965d173 |
548 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be |
549 | notified, and then you'll automatically be notified of progress on your bug |
550 | as I make changes. |
e4fc8a1e |
551 | |
552 | =head1 AUTHORS |
553 | |
b965d173 |
554 | Andy Armstrong C<< <andy@hexten.net> >> |
3c87ea76 |
555 | |
b965d173 |
556 | L<Test::Harness> (on which this module is based) has this attribution: |
e4fc8a1e |
557 | |
b965d173 |
558 | Either Tim Bunce or Andreas Koenig, we don't know. What we know for |
559 | sure is, that it was inspired by Larry Wall's F<TEST> script that came |
560 | with perl distributions for ages. Numerous anonymous contributors |
561 | exist. Andreas Koenig held the torch for many years, and then |
562 | Michael G Schwern. |
e4fc8a1e |
563 | |
b965d173 |
564 | =head1 LICENCE AND COPYRIGHT |
e4fc8a1e |
565 | |
b965d173 |
566 | Copyright (c) 2007, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved. |
e4fc8a1e |
567 | |
b965d173 |
568 | This module is free software; you can redistribute it and/or |
569 | modify it under the same terms as Perl itself. See L<perlartistic>. |
e4fc8a1e |
570 | |