Commit | Line | Data |
b965d173 |
1 | package TAP::Harness; |
2 | |
3 | use strict; |
4 | use Carp; |
5 | |
6 | use File::Spec; |
7 | use File::Path; |
8 | use IO::Handle; |
9 | |
10 | use TAP::Base; |
11 | use TAP::Parser; |
12 | use TAP::Parser::Aggregator; |
13 | use TAP::Parser::Multiplexer; |
14 | |
15 | use vars qw($VERSION @ISA); |
16 | |
17 | @ISA = qw(TAP::Base); |
18 | |
19 | =head1 NAME |
20 | |
21 | TAP::Harness - Run test scripts with statistics |
22 | |
23 | =head1 VERSION |
24 | |
25 | Version 3.05 |
26 | |
27 | =cut |
28 | |
29 | $VERSION = '3.05'; |
30 | |
31 | $ENV{HARNESS_ACTIVE} = 1; |
32 | $ENV{HARNESS_VERSION} = $VERSION; |
33 | |
34 | END { |
35 | |
36 | # For VMS. |
37 | delete $ENV{HARNESS_ACTIVE}; |
38 | delete $ENV{HARNESS_VERSION}; |
39 | } |
40 | |
41 | =head1 DESCRIPTION |
42 | |
43 | This is a simple test harness which allows tests to be run and results |
44 | automatically aggregated and output to STDOUT. |
45 | |
46 | =head1 SYNOPSIS |
47 | |
48 | use TAP::Harness; |
49 | my $harness = TAP::Harness->new( \%args ); |
50 | $harness->runtests(@tests); |
51 | |
52 | =cut |
53 | |
54 | my %VALIDATION_FOR; |
55 | my @FORMATTER_ARGS; |
56 | |
57 | sub _error { |
58 | my $self = shift; |
59 | return $self->{error} unless @_; |
60 | $self->{error} = shift; |
61 | } |
62 | |
63 | BEGIN { |
64 | |
65 | @FORMATTER_ARGS = qw( |
66 | directives verbosity timer failures errors stdout color |
67 | ); |
68 | |
69 | %VALIDATION_FOR = ( |
70 | lib => sub { |
71 | my ( $self, $libs ) = @_; |
72 | $libs = [$libs] unless 'ARRAY' eq ref $libs; |
73 | |
74 | return [ map {"-I$_"} @$libs ]; |
75 | }, |
76 | switches => sub { shift; shift }, |
77 | exec => sub { shift; shift }, |
78 | merge => sub { shift; shift }, |
79 | formatter_class => sub { shift; shift }, |
80 | formatter => sub { shift; shift }, |
81 | jobs => sub { shift; shift }, |
82 | fork => sub { shift; shift }, |
83 | test_args => sub { shift; shift }, |
84 | ); |
85 | |
86 | for my $method ( sort keys %VALIDATION_FOR ) { |
87 | no strict 'refs'; |
88 | if ( $method eq 'lib' || $method eq 'switches' ) { |
89 | *{$method} = sub { |
90 | my $self = shift; |
91 | unless (@_) { |
92 | $self->{$method} ||= []; |
93 | return wantarray |
94 | ? @{ $self->{$method} } |
95 | : $self->{$method}; |
96 | } |
97 | $self->_croak("Too many arguments to method '$method'") |
98 | if @_ > 1; |
99 | my $args = shift; |
100 | $args = [$args] unless ref $args; |
101 | $self->{$method} = $args; |
102 | return $self; |
103 | }; |
104 | } |
105 | else { |
106 | *{$method} = sub { |
107 | my $self = shift; |
108 | return $self->{$method} unless @_; |
109 | $self->{$method} = shift; |
110 | }; |
111 | } |
112 | } |
113 | |
114 | for my $method (@FORMATTER_ARGS) { |
115 | no strict 'refs'; |
116 | *{$method} = sub { |
117 | my $self = shift; |
118 | return $self->formatter->$method(@_); |
119 | }; |
120 | } |
121 | } |
122 | |
123 | ############################################################################## |
124 | |
125 | =head1 METHODS |
126 | |
127 | =head2 Class Methods |
128 | |
129 | =head3 C<new> |
130 | |
131 | my %args = ( |
132 | verbosity => 1, |
133 | lib => [ 'lib', 'blib/lib' ], |
134 | ) |
135 | my $harness = TAP::Harness->new( \%args ); |
136 | |
137 | The constructor returns a new C<TAP::Harness> object. It accepts an optional |
138 | hashref whose allowed keys are: |
139 | |
140 | =over 4 |
141 | |
142 | =item * C<verbosity> |
143 | |
144 | Set the verbosity level: |
145 | |
146 | 1 verbose Print individual test results to STDOUT. |
147 | 0 normal |
148 | -1 quiet Suppress some test output (mostly failures |
149 | while tests are running). |
150 | -2 really quiet Suppress everything but the tests summary. |
151 | |
152 | =item * C<timer> |
153 | |
154 | Append run time for each test to output. Uses L<Time::HiRes> if available. |
155 | |
156 | =item * C<failures> |
157 | |
158 | Only show test failures (this is a no-op if C<verbose> is selected). |
159 | |
160 | =item * C<lib> |
161 | |
162 | Accepts a scalar value or array ref of scalar values indicating which paths to |
163 | allowed libraries should be included if Perl tests are executed. Naturally, |
164 | this only makes sense in the context of tests written in Perl. |
165 | |
166 | =item * C<switches> |
167 | |
168 | Accepts a scalar value or array ref of scalar values indicating which switches |
169 | should be included if Perl tests are executed. Naturally, this only makes |
170 | sense in the context of tests written in Perl. |
171 | |
172 | =item * C<test_args> |
173 | |
174 | A reference to an C<@INC> style array of arguments to be passed to each |
175 | test program. |
176 | |
177 | =item * C<color> |
178 | |
179 | Attempt to produce color output. |
180 | |
181 | =item * C<exec> |
182 | |
183 | Typically, Perl tests are run through this. However, anything which spits out |
184 | TAP is fine. You can use this argument to specify the name of the program |
185 | (and optional switches) to run your tests with: |
186 | |
187 | exec => ['/usr/bin/ruby', '-w'] |
188 | |
189 | =item * C<merge> |
190 | |
191 | If C<merge> is true the harness will create parsers that merge STDOUT |
192 | and STDERR together for any processes they start. |
193 | |
194 | =item * C<formatter_class> |
195 | |
196 | The name of the class to use to format output. The default is |
197 | L<TAP::Formatter::Console>. |
198 | |
199 | =item * C<formatter> |
200 | |
201 | If set C<formatter> must be an object that is capable of formatting the |
202 | TAP output. See L<TAP::Formatter::Console> for an example. |
203 | |
204 | =item * C<errors> |
205 | |
206 | If parse errors are found in the TAP output, a note of this will be made |
207 | in the summary report. To see all of the parse errors, set this argument to |
208 | true: |
209 | |
210 | errors => 1 |
211 | |
212 | =item * C<directives> |
213 | |
214 | If set to a true value, only test results with directives will be displayed. |
215 | This overrides other settings such as C<verbose> or C<failures>. |
216 | |
217 | =item * C<stdout> |
218 | |
219 | A filehandle for catching standard output. |
220 | |
221 | =back |
222 | |
223 | Any keys for which the value is C<undef> will be ignored. |
224 | |
225 | =cut |
226 | |
227 | # new supplied by TAP::Base |
228 | |
229 | { |
230 | my @legal_callback = qw( |
231 | parser_args |
232 | made_parser |
233 | before_runtests |
234 | after_runtests |
235 | after_test |
236 | ); |
237 | |
238 | sub _initialize { |
239 | my ( $self, $arg_for ) = @_; |
240 | $arg_for ||= {}; |
241 | |
242 | $self->SUPER::_initialize( $arg_for, \@legal_callback ); |
243 | my %arg_for = %$arg_for; # force a shallow copy |
244 | |
245 | for my $name ( sort keys %VALIDATION_FOR ) { |
246 | my $property = delete $arg_for{$name}; |
247 | if ( defined $property ) { |
248 | my $validate = $VALIDATION_FOR{$name}; |
249 | |
250 | my $value = $self->$validate($property); |
251 | if ( $self->_error ) { |
252 | $self->_croak; |
253 | } |
254 | $self->$name($value); |
255 | } |
256 | } |
257 | |
258 | $self->jobs(1) unless defined $self->jobs; |
259 | |
260 | unless ( $self->formatter ) { |
261 | |
262 | $self->formatter_class( my $class = $self->formatter_class |
263 | || 'TAP::Formatter::Console' ); |
264 | |
265 | croak "Bad module name $class" |
266 | unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; |
267 | |
268 | eval "require $class"; |
269 | $self->_croak("Can't load $class") if $@; |
270 | |
271 | # This is a little bodge to preserve legacy behaviour. It's |
272 | # pretty horrible that we know which args are destined for |
273 | # the formatter. |
274 | my %formatter_args = ( jobs => $self->jobs ); |
275 | for my $name (@FORMATTER_ARGS) { |
276 | if ( defined( my $property = delete $arg_for{$name} ) ) { |
277 | $formatter_args{$name} = $property; |
278 | } |
279 | } |
280 | |
281 | $self->formatter( $class->new( \%formatter_args ) ); |
282 | } |
283 | |
284 | if ( my @props = sort keys %arg_for ) { |
285 | $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); |
286 | } |
287 | |
288 | return $self; |
289 | } |
290 | } |
291 | |
292 | ############################################################################## |
293 | |
294 | =head2 Instance Methods |
295 | |
296 | =head3 C<runtests> |
297 | |
298 | $harness->runtests(@tests); |
299 | |
300 | Accepts and array of C<@tests> to be run. This should generally be the names |
301 | of test files, but this is not required. Each element in C<@tests> will be |
302 | passed to C<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> for more |
303 | information. |
304 | |
305 | It is possible to provide aliases that will be displayed in place of the |
306 | test name by supplying the test as a reference to an array containing |
307 | C<< [ $test, $alias ] >>: |
308 | |
309 | $harness->runtests( [ 't/foo.t', 'Foo Once' ], |
310 | [ 't/foo.t', 'Foo Twice' ] ); |
311 | |
312 | Normally it is an error to attempt to run the same test twice. Aliases |
313 | allow you to overcome this limitation by giving each run of the test a |
314 | unique name. |
315 | |
316 | Tests will be run in the order found. |
317 | |
318 | If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it |
319 | should name a directory into which a copy of the raw TAP for each test |
320 | will be written. TAP is written to files named for each test. |
321 | Subdirectories will be created as needed. |
322 | |
323 | Returns a L<TAP::Parser::Aggregator> containing the test results. |
324 | |
325 | =cut |
326 | |
327 | sub runtests { |
328 | my ( $self, @tests ) = @_; |
329 | |
330 | my $aggregate = TAP::Parser::Aggregator->new; |
331 | |
332 | $self->_make_callback( 'before_runtests', $aggregate ); |
333 | $self->aggregate_tests( $aggregate, @tests ); |
334 | $self->formatter->summary($aggregate); |
335 | $self->_make_callback( 'after_runtests', $aggregate ); |
336 | |
337 | return $aggregate; |
338 | } |
339 | |
340 | =head3 C<aggregate_tests> |
341 | |
342 | $harness->aggregate_tests( $aggregate, @tests ); |
343 | |
344 | Tests will be run in the order found. |
345 | |
346 | =cut |
347 | |
348 | sub _after_test { |
349 | my ( $self, $aggregate, $test, $parser ) = @_; |
350 | |
351 | $self->_make_callback( 'after_test', $test, $parser ); |
352 | $aggregate->add( $test->[1], $parser ); |
353 | } |
354 | |
355 | sub _aggregate_forked { |
356 | my ( $self, $aggregate, @tests ) = @_; |
357 | |
358 | eval { require Parallel::Iterator }; |
359 | |
360 | croak "Parallel::Iterator required for --fork option ($@)" |
361 | if $@; |
362 | |
363 | my $iter = Parallel::Iterator::iterate( |
364 | { workers => $self->jobs || 0 }, |
365 | sub { |
366 | my ( $id, $test ) = @_; |
367 | |
368 | my ( $parser, $session ) = $self->make_parser($test); |
369 | |
370 | while ( defined( my $result = $parser->next ) ) { |
371 | exit 1 if $result->is_bailout; |
372 | } |
373 | |
374 | $self->finish_parser( $parser, $session ); |
375 | |
376 | # Can't serialise coderefs... |
377 | delete $parser->{_iter}; |
378 | delete $parser->{_stream}; |
379 | delete $parser->{_grammar}; |
380 | return $parser; |
381 | }, |
382 | \@tests |
383 | ); |
384 | |
385 | while ( my ( $id, $parser ) = $iter->() ) { |
386 | $self->_after_test( $aggregate, $tests[$id], $parser ); |
387 | } |
388 | |
389 | return; |
390 | } |
391 | |
392 | sub _aggregate_parallel { |
393 | my ( $self, $aggregate, @tests ) = @_; |
394 | |
395 | my $jobs = $self->jobs; |
396 | my $mux = TAP::Parser::Multiplexer->new; |
397 | |
398 | RESULT: { |
399 | |
400 | # Keep multiplexer topped up |
401 | while ( @tests && $mux->parsers < $jobs ) { |
402 | my $test = shift @tests; |
403 | my ( $parser, $session ) = $self->make_parser($test); |
404 | $mux->add( $parser, [ $session, $test ] ); |
405 | } |
406 | |
407 | if ( my ( $parser, $stash, $result ) = $mux->next ) { |
408 | my ( $session, $test ) = @$stash; |
409 | if ( defined $result ) { |
410 | $session->result($result); |
411 | exit 1 if $result->is_bailout; |
412 | } |
413 | else { |
414 | |
415 | # End of parser. Automatically removed from the mux. |
416 | $self->finish_parser( $parser, $session ); |
417 | $self->_after_test( $aggregate, $test, $parser ); |
418 | } |
419 | redo RESULT; |
420 | } |
421 | } |
422 | |
423 | return; |
424 | } |
425 | |
426 | sub _aggregate_single { |
427 | my ( $self, $aggregate, @tests ) = @_; |
428 | |
429 | for my $test (@tests) { |
430 | my ( $parser, $session ) = $self->make_parser($test); |
431 | |
432 | while ( defined( my $result = $parser->next ) ) { |
433 | $session->result($result); |
434 | exit 1 if $result->is_bailout; |
435 | } |
436 | |
437 | $self->finish_parser( $parser, $session ); |
438 | $self->_after_test( $aggregate, $test, $parser ); |
439 | } |
440 | |
441 | return; |
442 | } |
443 | |
444 | sub aggregate_tests { |
445 | my ( $self, $aggregate, @tests ) = @_; |
446 | |
447 | my $jobs = $self->jobs; |
448 | |
449 | my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests; |
450 | |
451 | # Formatter gets only names |
452 | $self->formatter->prepare( map { $_->[1] } @expanded ); |
453 | $aggregate->start; |
454 | |
455 | if ( $self->jobs > 1 ) { |
456 | if ( $self->fork ) { |
457 | $self->_aggregate_forked( $aggregate, @expanded ); |
458 | } |
459 | else { |
460 | $self->_aggregate_parallel( $aggregate, @expanded ); |
461 | } |
462 | } |
463 | else { |
464 | $self->_aggregate_single( $aggregate, @expanded ); |
465 | } |
466 | |
467 | $aggregate->stop; |
468 | |
469 | return; |
470 | } |
471 | |
472 | =head3 C<jobs> |
473 | |
474 | Returns the number of concurrent test runs the harness is handling. For the default |
475 | harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel> |
476 | will override this to return the number of jobs it is handling. |
477 | |
478 | =head3 C<fork> |
479 | |
480 | If true the harness will attempt to fork and run the parser for each |
481 | test in a separate process. Currently this option requires |
482 | L<Parallel::Iterator> to be installed. |
483 | |
484 | =cut |
485 | |
486 | ############################################################################## |
487 | |
488 | =head1 SUBCLASSING |
489 | |
490 | C<TAP::Harness> is designed to be (mostly) easy to subclass. If you don't |
491 | like how a particular feature functions, just override the desired methods. |
492 | |
493 | =head2 Methods |
494 | |
495 | TODO: This is out of date |
496 | |
497 | The following methods are ones you may wish to override if you want to |
498 | subclass C<TAP::Harness>. |
499 | |
500 | =head3 C<summary> |
501 | |
502 | $harness->summary( \%args ); |
503 | |
504 | C<summary> prints the summary report after all tests are run. The argument is |
505 | a hashref with the following keys: |
506 | |
507 | =over 4 |
508 | |
509 | =item * C<start> |
510 | |
511 | This is created with C<< Benchmark->new >> and it the time the tests started. |
512 | You can print a useful summary time, if desired, with: |
513 | |
514 | $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' )); |
515 | |
516 | =item * C<tests> |
517 | |
518 | This is an array reference of all test names. To get the L<TAP::Parser> |
519 | object for individual tests: |
520 | |
521 | my $aggregate = $args->{aggregate}; |
522 | my $tests = $args->{tests}; |
523 | |
524 | for my $name ( @$tests ) { |
525 | my ($parser) = $aggregate->parsers($test); |
526 | ... do something with $parser |
527 | } |
528 | |
529 | This is a bit clunky and will be cleaned up in a later release. |
530 | |
531 | =back |
532 | |
533 | =cut |
534 | |
535 | sub _get_parser_args { |
536 | my ( $self, $test ) = @_; |
537 | my $test_prog = $test->[0]; |
538 | my %args = (); |
539 | my @switches; |
540 | @switches = $self->lib if $self->lib; |
541 | push @switches => $self->switches if $self->switches; |
542 | $args{switches} = \@switches; |
543 | $args{spool} = $self->_open_spool($test_prog); |
544 | $args{merge} = $self->merge; |
545 | $args{exec} = $self->exec; |
546 | |
547 | if ( my $exec = $self->exec ) { |
548 | $args{exec} = [ @$exec, $test_prog ]; |
549 | } |
550 | else { |
551 | $args{source} = $test_prog; |
552 | } |
553 | |
554 | if ( defined( my $test_args = $self->test_args ) ) { |
555 | $args{test_args} = $test_args; |
556 | } |
557 | |
558 | return \%args; |
559 | } |
560 | |
561 | =head3 C<make_parser> |
562 | |
563 | Make a new parser and display formatter session. Typically used and/or |
564 | overridden in subclasses. |
565 | |
566 | my ( $parser, $session ) = $harness->make_parser; |
567 | |
568 | |
569 | =cut |
570 | |
571 | sub make_parser { |
572 | my ( $self, $test ) = @_; |
573 | |
574 | my $args = $self->_get_parser_args($test); |
575 | $self->_make_callback( 'parser_args', $args, $test ); |
576 | my $parser = TAP::Parser->new($args); |
577 | |
578 | $self->_make_callback( 'made_parser', $parser, $test ); |
579 | my $session = $self->formatter->open_test( $test->[1], $parser ); |
580 | |
581 | return ( $parser, $session ); |
582 | } |
583 | |
584 | =head3 C<finish_parser> |
585 | |
586 | Terminate use of a parser. Typically used and/or overridden in |
587 | subclasses. The parser isn't destroyed as a result of this. |
588 | |
589 | =cut |
590 | |
591 | sub finish_parser { |
592 | my ( $self, $parser, $session ) = @_; |
593 | |
594 | $session->close_test; |
595 | $self->_close_spool($parser); |
596 | |
597 | return $parser; |
598 | } |
599 | |
600 | sub _open_spool { |
601 | my $self = shift; |
602 | my $test = shift; |
603 | |
604 | if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { |
605 | |
606 | my $spool = File::Spec->catfile( $spool_dir, $test ); |
607 | |
608 | # Make the directory |
609 | my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); |
610 | my $path = File::Spec->catpath( $vol, $dir, '' ); |
611 | eval { mkpath($path) }; |
612 | $self->_croak($@) if $@; |
613 | |
614 | my $spool_handle = IO::Handle->new; |
615 | open( $spool_handle, ">$spool" ) |
616 | or $self->_croak(" Can't write $spool ( $! ) "); |
617 | |
618 | return $spool_handle; |
619 | } |
620 | |
621 | return; |
622 | } |
623 | |
624 | sub _close_spool { |
625 | my $self = shift; |
626 | my ($parser) = @_; |
627 | |
628 | if ( my $spool_handle = $parser->delete_spool ) { |
629 | close($spool_handle) |
630 | or $self->_croak(" Error closing TAP spool file( $! ) \n "); |
631 | } |
632 | |
633 | return; |
634 | } |
635 | |
636 | sub _croak { |
637 | my ( $self, $message ) = @_; |
638 | unless ($message) { |
639 | $message = $self->_error; |
640 | } |
641 | $self->SUPER::_croak($message); |
642 | |
643 | return; |
644 | } |
645 | |
646 | =head1 REPLACING |
647 | |
648 | If you like the C<prove> utility and L<TAP::Parser> but you want your |
649 | own harness, all you need to do is write one and provide C<new> and |
650 | C<runtests> methods. Then you can use the C<prove> utility like so: |
651 | |
652 | prove --harness My::Test::Harness |
653 | |
654 | Note that while C<prove> accepts a list of tests (or things to be |
655 | tested), C<new> has a fairly rich set of arguments. You'll probably want |
656 | to read over this code carefully to see how all of them are being used. |
657 | |
658 | =head1 SEE ALSO |
659 | |
660 | L<Test::Harness> |
661 | |
662 | =cut |
663 | |
664 | 1; |
665 | |
666 | # vim:ts=4:sw=4:et:sta |