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 | |
2a7f4b9b |
25 | Version 3.10 |
b965d173 |
26 | |
27 | =cut |
28 | |
2a7f4b9b |
29 | $VERSION = '3.10'; |
b965d173 |
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 ); |
53bc175b |
333 | $aggregate->start; |
b965d173 |
334 | $self->aggregate_tests( $aggregate, @tests ); |
53bc175b |
335 | $aggregate->stop; |
b965d173 |
336 | $self->formatter->summary($aggregate); |
337 | $self->_make_callback( 'after_runtests', $aggregate ); |
338 | |
339 | return $aggregate; |
340 | } |
341 | |
b965d173 |
342 | sub _after_test { |
343 | my ( $self, $aggregate, $test, $parser ) = @_; |
344 | |
345 | $self->_make_callback( 'after_test', $test, $parser ); |
346 | $aggregate->add( $test->[1], $parser ); |
347 | } |
348 | |
349 | sub _aggregate_forked { |
350 | my ( $self, $aggregate, @tests ) = @_; |
351 | |
352 | eval { require Parallel::Iterator }; |
353 | |
354 | croak "Parallel::Iterator required for --fork option ($@)" |
355 | if $@; |
356 | |
357 | my $iter = Parallel::Iterator::iterate( |
358 | { workers => $self->jobs || 0 }, |
359 | sub { |
360 | my ( $id, $test ) = @_; |
361 | |
362 | my ( $parser, $session ) = $self->make_parser($test); |
363 | |
364 | while ( defined( my $result = $parser->next ) ) { |
365 | exit 1 if $result->is_bailout; |
366 | } |
367 | |
368 | $self->finish_parser( $parser, $session ); |
369 | |
370 | # Can't serialise coderefs... |
371 | delete $parser->{_iter}; |
372 | delete $parser->{_stream}; |
373 | delete $parser->{_grammar}; |
374 | return $parser; |
375 | }, |
376 | \@tests |
377 | ); |
378 | |
379 | while ( my ( $id, $parser ) = $iter->() ) { |
380 | $self->_after_test( $aggregate, $tests[$id], $parser ); |
381 | } |
382 | |
383 | return; |
384 | } |
385 | |
386 | sub _aggregate_parallel { |
387 | my ( $self, $aggregate, @tests ) = @_; |
388 | |
389 | my $jobs = $self->jobs; |
390 | my $mux = TAP::Parser::Multiplexer->new; |
391 | |
392 | RESULT: { |
393 | |
394 | # Keep multiplexer topped up |
395 | while ( @tests && $mux->parsers < $jobs ) { |
396 | my $test = shift @tests; |
397 | my ( $parser, $session ) = $self->make_parser($test); |
398 | $mux->add( $parser, [ $session, $test ] ); |
399 | } |
400 | |
401 | if ( my ( $parser, $stash, $result ) = $mux->next ) { |
402 | my ( $session, $test ) = @$stash; |
403 | if ( defined $result ) { |
404 | $session->result($result); |
405 | exit 1 if $result->is_bailout; |
406 | } |
407 | else { |
408 | |
409 | # End of parser. Automatically removed from the mux. |
410 | $self->finish_parser( $parser, $session ); |
411 | $self->_after_test( $aggregate, $test, $parser ); |
412 | } |
413 | redo RESULT; |
414 | } |
415 | } |
416 | |
417 | return; |
418 | } |
419 | |
420 | sub _aggregate_single { |
421 | my ( $self, $aggregate, @tests ) = @_; |
422 | |
423 | for my $test (@tests) { |
424 | my ( $parser, $session ) = $self->make_parser($test); |
425 | |
426 | while ( defined( my $result = $parser->next ) ) { |
427 | $session->result($result); |
69f36734 |
428 | if ( $result->is_bailout ) { |
429 | |
430 | # Keep reading until input is exhausted in the hope |
431 | # of allowing any pending diagnostics to show up. |
432 | 1 while $parser->next; |
433 | exit 1; |
434 | } |
b965d173 |
435 | } |
436 | |
437 | $self->finish_parser( $parser, $session ); |
438 | $self->_after_test( $aggregate, $test, $parser ); |
439 | } |
440 | |
441 | return; |
442 | } |
443 | |
53bc175b |
444 | =head3 C<aggregate_tests> |
445 | |
446 | $harness->aggregate_tests( $aggregate, @tests ); |
447 | |
448 | Run the named tests and display a summary of result. Tests will be run |
449 | in the order found. |
450 | |
451 | Test results will be added to the supplied L<TAP::Parser::Aggregator>. |
452 | C<aggregate_tests> may be called multiple times to run several sets of |
453 | tests. Multiple C<Test::Harness> instances may be used to pass results |
454 | to a single aggregator so that different parts of a complex test suite |
455 | may be run using different C<TAP::Harness> settings. This is useful, for |
456 | example, in the case where some tests should run in parallel but others |
457 | are unsuitable for parallel execution. |
458 | |
459 | my $formatter = TAP::Formatter::Console->new; |
460 | my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); |
461 | my $par_harness = TAP::Harness->new( { formatter => $formatter, |
462 | jobs => 9 } ); |
463 | my $aggregator = TAP::Parser::Aggregator->new; |
464 | |
465 | $aggregator->start(); |
466 | $ser_harness->aggregate_tests( $aggregator, @ser_tests ); |
467 | $par_harness->aggregate_tests( $aggregator, @par_tests ); |
468 | $aggregator->stop(); |
469 | $formatter->summary( $aggregator ); |
470 | |
471 | Note that for simpler testing requirements it will often be possible to |
472 | replace the above code with a single call to C<runtests>. |
473 | |
474 | Each elements of the @tests array is either |
475 | |
476 | =over |
477 | |
478 | =item * the file name of a test script to run |
479 | |
480 | =item * a reference to a [ file name, display name ] |
481 | |
482 | =back |
483 | |
484 | When you supply a separate display name it becomes possible to run a |
485 | test more than once; the display name is effectively the alias by which |
486 | the test is known inside the harness. The harness doesn't care if it |
bd3ac2f1 |
487 | runs the same script more than once when each invocation uses a |
53bc175b |
488 | different name. |
489 | |
490 | =cut |
491 | |
b965d173 |
492 | sub aggregate_tests { |
493 | my ( $self, $aggregate, @tests ) = @_; |
494 | |
495 | my $jobs = $self->jobs; |
496 | |
497 | my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests; |
498 | |
bd3ac2f1 |
499 | # #12458 |
500 | local $ENV{HARNESS_IS_VERBOSE} = 1 |
501 | if $self->formatter->verbosity > 0; |
502 | |
b965d173 |
503 | # Formatter gets only names |
504 | $self->formatter->prepare( map { $_->[1] } @expanded ); |
b965d173 |
505 | |
506 | if ( $self->jobs > 1 ) { |
507 | if ( $self->fork ) { |
508 | $self->_aggregate_forked( $aggregate, @expanded ); |
509 | } |
510 | else { |
511 | $self->_aggregate_parallel( $aggregate, @expanded ); |
512 | } |
513 | } |
514 | else { |
515 | $self->_aggregate_single( $aggregate, @expanded ); |
516 | } |
517 | |
b965d173 |
518 | return; |
519 | } |
520 | |
521 | =head3 C<jobs> |
522 | |
523 | Returns the number of concurrent test runs the harness is handling. For the default |
524 | harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel> |
525 | will override this to return the number of jobs it is handling. |
526 | |
527 | =head3 C<fork> |
528 | |
529 | If true the harness will attempt to fork and run the parser for each |
530 | test in a separate process. Currently this option requires |
531 | L<Parallel::Iterator> to be installed. |
532 | |
533 | =cut |
534 | |
535 | ############################################################################## |
536 | |
537 | =head1 SUBCLASSING |
538 | |
539 | C<TAP::Harness> is designed to be (mostly) easy to subclass. If you don't |
540 | like how a particular feature functions, just override the desired methods. |
541 | |
542 | =head2 Methods |
543 | |
544 | TODO: This is out of date |
545 | |
546 | The following methods are ones you may wish to override if you want to |
547 | subclass C<TAP::Harness>. |
548 | |
549 | =head3 C<summary> |
550 | |
551 | $harness->summary( \%args ); |
552 | |
553 | C<summary> prints the summary report after all tests are run. The argument is |
554 | a hashref with the following keys: |
555 | |
556 | =over 4 |
557 | |
558 | =item * C<start> |
559 | |
560 | This is created with C<< Benchmark->new >> and it the time the tests started. |
561 | You can print a useful summary time, if desired, with: |
562 | |
563 | $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' )); |
564 | |
565 | =item * C<tests> |
566 | |
567 | This is an array reference of all test names. To get the L<TAP::Parser> |
568 | object for individual tests: |
569 | |
570 | my $aggregate = $args->{aggregate}; |
571 | my $tests = $args->{tests}; |
572 | |
573 | for my $name ( @$tests ) { |
574 | my ($parser) = $aggregate->parsers($test); |
575 | ... do something with $parser |
576 | } |
577 | |
578 | This is a bit clunky and will be cleaned up in a later release. |
579 | |
580 | =back |
581 | |
582 | =cut |
583 | |
584 | sub _get_parser_args { |
585 | my ( $self, $test ) = @_; |
586 | my $test_prog = $test->[0]; |
587 | my %args = (); |
588 | my @switches; |
589 | @switches = $self->lib if $self->lib; |
590 | push @switches => $self->switches if $self->switches; |
591 | $args{switches} = \@switches; |
592 | $args{spool} = $self->_open_spool($test_prog); |
593 | $args{merge} = $self->merge; |
594 | $args{exec} = $self->exec; |
595 | |
596 | if ( my $exec = $self->exec ) { |
597 | $args{exec} = [ @$exec, $test_prog ]; |
598 | } |
599 | else { |
600 | $args{source} = $test_prog; |
601 | } |
602 | |
603 | if ( defined( my $test_args = $self->test_args ) ) { |
604 | $args{test_args} = $test_args; |
605 | } |
606 | |
607 | return \%args; |
608 | } |
609 | |
610 | =head3 C<make_parser> |
611 | |
612 | Make a new parser and display formatter session. Typically used and/or |
613 | overridden in subclasses. |
614 | |
615 | my ( $parser, $session ) = $harness->make_parser; |
616 | |
617 | |
618 | =cut |
619 | |
620 | sub make_parser { |
621 | my ( $self, $test ) = @_; |
622 | |
623 | my $args = $self->_get_parser_args($test); |
624 | $self->_make_callback( 'parser_args', $args, $test ); |
625 | my $parser = TAP::Parser->new($args); |
626 | |
627 | $self->_make_callback( 'made_parser', $parser, $test ); |
628 | my $session = $self->formatter->open_test( $test->[1], $parser ); |
629 | |
630 | return ( $parser, $session ); |
631 | } |
632 | |
633 | =head3 C<finish_parser> |
634 | |
635 | Terminate use of a parser. Typically used and/or overridden in |
636 | subclasses. The parser isn't destroyed as a result of this. |
637 | |
638 | =cut |
639 | |
640 | sub finish_parser { |
641 | my ( $self, $parser, $session ) = @_; |
642 | |
643 | $session->close_test; |
644 | $self->_close_spool($parser); |
645 | |
646 | return $parser; |
647 | } |
648 | |
649 | sub _open_spool { |
650 | my $self = shift; |
651 | my $test = shift; |
652 | |
653 | if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { |
654 | |
655 | my $spool = File::Spec->catfile( $spool_dir, $test ); |
656 | |
657 | # Make the directory |
658 | my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); |
659 | my $path = File::Spec->catpath( $vol, $dir, '' ); |
660 | eval { mkpath($path) }; |
661 | $self->_croak($@) if $@; |
662 | |
663 | my $spool_handle = IO::Handle->new; |
664 | open( $spool_handle, ">$spool" ) |
665 | or $self->_croak(" Can't write $spool ( $! ) "); |
666 | |
667 | return $spool_handle; |
668 | } |
669 | |
670 | return; |
671 | } |
672 | |
673 | sub _close_spool { |
674 | my $self = shift; |
675 | my ($parser) = @_; |
676 | |
677 | if ( my $spool_handle = $parser->delete_spool ) { |
678 | close($spool_handle) |
679 | or $self->_croak(" Error closing TAP spool file( $! ) \n "); |
680 | } |
681 | |
682 | return; |
683 | } |
684 | |
685 | sub _croak { |
686 | my ( $self, $message ) = @_; |
687 | unless ($message) { |
688 | $message = $self->_error; |
689 | } |
690 | $self->SUPER::_croak($message); |
691 | |
692 | return; |
693 | } |
694 | |
695 | =head1 REPLACING |
696 | |
697 | If you like the C<prove> utility and L<TAP::Parser> but you want your |
698 | own harness, all you need to do is write one and provide C<new> and |
699 | C<runtests> methods. Then you can use the C<prove> utility like so: |
700 | |
701 | prove --harness My::Test::Harness |
702 | |
703 | Note that while C<prove> accepts a list of tests (or things to be |
704 | tested), C<new> has a fairly rich set of arguments. You'll probably want |
705 | to read over this code carefully to see how all of them are being used. |
706 | |
707 | =head1 SEE ALSO |
708 | |
709 | L<Test::Harness> |
710 | |
711 | =cut |
712 | |
713 | 1; |
714 | |
715 | # vim:ts=4:sw=4:et:sta |