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