12 use TAP::Parser::Aggregator;
13 use TAP::Parser::Multiplexer;
14 use TAP::Parser::Scheduler;
16 use vars qw($VERSION @ISA);
22 TAP::Harness - Run test scripts with statistics
32 $ENV{HARNESS_ACTIVE} = 1;
33 $ENV{HARNESS_VERSION} = $VERSION;
38 delete $ENV{HARNESS_ACTIVE};
39 delete $ENV{HARNESS_VERSION};
44 This is a simple test harness which allows tests to be run and results
45 automatically aggregated and output to STDOUT.
50 my $harness = TAP::Harness->new( \%args );
51 $harness->runtests(@tests);
60 return $self->{error} unless @_;
61 $self->{error} = shift;
67 directives verbosity timer failures errors stdout color
72 my ( $self, $libs ) = @_;
73 $libs = [$libs] unless 'ARRAY' eq ref $libs;
75 return [ map {"-I$_"} @$libs ];
77 switches => sub { shift; shift },
78 exec => sub { shift; shift },
79 merge => sub { shift; shift },
80 formatter_class => sub { shift; shift },
81 formatter => sub { shift; shift },
82 jobs => sub { shift; shift },
83 fork => sub { shift; shift },
84 test_args => sub { shift; shift },
85 ignore_exit => sub { shift; shift },
86 rules => sub { shift; shift },
89 for my $method ( sort keys %VALIDATION_FOR ) {
91 if ( $method eq 'lib' || $method eq 'switches' ) {
95 $self->{$method} ||= [];
97 ? @{ $self->{$method} }
100 $self->_croak("Too many arguments to method '$method'")
103 $args = [$args] unless ref $args;
104 $self->{$method} = $args;
111 return $self->{$method} unless @_;
112 $self->{$method} = shift;
117 for my $method (@FORMATTER_ARGS) {
121 return $self->formatter->$method(@_);
126 ##############################################################################
136 lib => [ 'lib', 'blib/lib' ],
138 my $harness = TAP::Harness->new( \%args );
140 The constructor returns a new C<TAP::Harness> object. It accepts an optional
141 hashref whose allowed keys are:
147 Set the verbosity level:
149 1 verbose Print individual test results to STDOUT.
151 -1 quiet Suppress some test output (mostly failures
152 while tests are running).
153 -2 really quiet Suppress everything but the tests summary.
157 Append run time for each test to output. Uses L<Time::HiRes> if available.
161 Only show test failures (this is a no-op if C<verbose> is selected).
165 Accepts a scalar value or array ref of scalar values indicating which paths to
166 allowed libraries should be included if Perl tests are executed. Naturally,
167 this only makes sense in the context of tests written in Perl.
171 Accepts a scalar value or array ref of scalar values indicating which switches
172 should be included if Perl tests are executed. Naturally, this only makes
173 sense in the context of tests written in Perl.
177 A reference to an C<@INC> style array of arguments to be passed to each
182 Attempt to produce color output.
186 Typically, Perl tests are run through this. However, anything which spits out
187 TAP is fine. You can use this argument to specify the name of the program
188 (and optional switches) to run your tests with:
190 exec => ['/usr/bin/ruby', '-w']
192 You can also pass a subroutine reference in order to determine and return the
193 proper program to run based on a given test script. The subroutine reference
194 should expect the TAP::Harness object itself as the first argument, and the
195 file name as the second argument. It should return an array reference
196 containing the command to be run and including the test file name. It can also
197 simply return C<undef>, in which case TAP::Harness will fall back on executing
198 the test script in Perl:
201 my ( $harness, $test_file ) = @_;
202 # Let Perl tests run.
203 return undef if $test_file =~ /[.]t$/;
204 return [ qw( /usr/bin/ruby -w ), $test_file ] if $test_file =~ /[.]rb$/;
209 If C<merge> is true the harness will create parsers that merge STDOUT
210 and STDERR together for any processes they start.
212 =item * C<formatter_class>
214 The name of the class to use to format output. The default is
215 L<TAP::Formatter::Console>.
219 If set C<formatter> must be an object that is capable of formatting the
220 TAP output. See L<TAP::Formatter::Console> for an example.
224 If parse errors are found in the TAP output, a note of this will be made
225 in the summary report. To see all of the parse errors, set this argument to
230 =item * C<directives>
232 If set to a true value, only test results with directives will be displayed.
233 This overrides other settings such as C<verbose> or C<failures>.
235 =item * C<ignore_exit>
237 If set to a true value instruct C<TAP::Parser> to ignore exit and wait
238 status from test scripts.
242 A reference to a hash of rules that control which tests may be
243 executed in parallel. This is an experimental feature and the
244 interface may change.
248 { seq => '../ext/DB_File/t/*' },
249 { seq => '../ext/IO_Compress_Zlib/t/*' },
250 { seq => '../lib/CPANPLUS/*' },
251 { seq => '../lib/ExtUtils/t/*' },
259 A filehandle for catching standard output.
263 Any keys for which the value is C<undef> will be ignored.
267 # new supplied by TAP::Base
270 my @legal_callback = qw(
279 my ( $self, $arg_for ) = @_;
282 $self->SUPER::_initialize( $arg_for, \@legal_callback );
283 my %arg_for = %$arg_for; # force a shallow copy
285 for my $name ( sort keys %VALIDATION_FOR ) {
286 my $property = delete $arg_for{$name};
287 if ( defined $property ) {
288 my $validate = $VALIDATION_FOR{$name};
290 my $value = $self->$validate($property);
291 if ( $self->_error ) {
294 $self->$name($value);
298 $self->jobs(1) unless defined $self->jobs;
300 unless ( $self->formatter ) {
302 $self->formatter_class( my $class = $self->formatter_class
303 || 'TAP::Formatter::Console' );
305 croak "Bad module name $class"
306 unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
308 eval "require $class";
309 $self->_croak("Can't load $class") if $@;
311 # This is a little bodge to preserve legacy behaviour. It's
312 # pretty horrible that we know which args are destined for
314 my %formatter_args = ( jobs => $self->jobs );
315 for my $name (@FORMATTER_ARGS) {
316 if ( defined( my $property = delete $arg_for{$name} ) ) {
317 $formatter_args{$name} = $property;
321 $self->formatter( $class->new( \%formatter_args ) );
324 if ( my @props = sort keys %arg_for ) {
325 $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
332 ##############################################################################
334 =head2 Instance Methods
338 $harness->runtests(@tests);
340 Accepts and array of C<@tests> to be run. This should generally be the names
341 of test files, but this is not required. Each element in C<@tests> will be
342 passed to C<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> for more
345 It is possible to provide aliases that will be displayed in place of the
346 test name by supplying the test as a reference to an array containing
347 C<< [ $test, $alias ] >>:
349 $harness->runtests( [ 't/foo.t', 'Foo Once' ],
350 [ 't/foo.t', 'Foo Twice' ] );
352 Normally it is an error to attempt to run the same test twice. Aliases
353 allow you to overcome this limitation by giving each run of the test a
356 Tests will be run in the order found.
358 If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
359 should name a directory into which a copy of the raw TAP for each test
360 will be written. TAP is written to files named for each test.
361 Subdirectories will be created as needed.
363 Returns a L<TAP::Parser::Aggregator> containing the test results.
368 my ( $self, @tests ) = @_;
370 my $aggregate = TAP::Parser::Aggregator->new;
372 $self->_make_callback( 'before_runtests', $aggregate );
374 $self->aggregate_tests( $aggregate, @tests );
376 $self->summary($aggregate);
377 $self->_make_callback( 'after_runtests', $aggregate );
384 Output the summary for a TAP::Parser::Aggregator.
389 my ( $self, $aggregate ) = @_;
390 $self->formatter->summary($aggregate);
394 my ( $self, $aggregate, $job, $parser ) = @_;
396 $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
397 $aggregate->add( $job->description, $parser );
400 sub _aggregate_forked {
401 my ( $self, $aggregate, $scheduler ) = @_;
403 eval { require Parallel::Iterator };
405 croak "Parallel::Iterator required for --fork option ($@)"
408 my $iter = Parallel::Iterator::iterate(
409 { workers => $self->jobs || 0 },
413 return if $job->is_spinner;
415 my ( $parser, $session ) = $self->make_parser($job);
417 while ( defined( my $result = $parser->next ) ) {
418 exit 1 if $result->is_bailout;
421 $self->finish_parser( $parser, $session );
423 # Can't serialise coderefs...
424 delete $parser->{_iter};
425 delete $parser->{_stream};
426 delete $parser->{_grammar};
429 sub { $scheduler->get_job }
432 while ( my ( $job, $parser ) = $iter->() ) {
433 next if $job->is_spinner;
434 $self->_after_test( $aggregate, $job, $parser );
441 sub _aggregate_parallel {
442 my ( $self, $aggregate, $scheduler ) = @_;
444 my $jobs = $self->jobs;
445 my $mux = TAP::Parser::Multiplexer->new;
449 # Keep multiplexer topped up
451 while ( $mux->parsers < $jobs ) {
452 my $job = $scheduler->get_job;
454 # If we hit a spinner stop filling and start running.
455 last FILL if !defined $job || $job->is_spinner;
457 my ( $parser, $session ) = $self->make_parser($job);
458 $mux->add( $parser, [ $session, $job ] );
461 if ( my ( $parser, $stash, $result ) = $mux->next ) {
462 my ( $session, $job ) = @$stash;
463 if ( defined $result ) {
464 $session->result($result);
465 exit 1 if $result->is_bailout;
469 # End of parser. Automatically removed from the mux.
470 $self->finish_parser( $parser, $session );
471 $self->_after_test( $aggregate, $job, $parser );
481 sub _aggregate_single {
482 my ( $self, $aggregate, $scheduler ) = @_;
485 while ( my $job = $scheduler->get_job ) {
486 next JOB if $job->is_spinner;
488 my ( $parser, $session ) = $self->make_parser($job);
490 while ( defined( my $result = $parser->next ) ) {
491 $session->result($result);
492 if ( $result->is_bailout ) {
494 # Keep reading until input is exhausted in the hope
495 # of allowing any pending diagnostics to show up.
496 1 while $parser->next;
501 $self->finish_parser( $parser, $session );
502 $self->_after_test( $aggregate, $job, $parser );
509 =head3 C<aggregate_tests>
511 $harness->aggregate_tests( $aggregate, @tests );
513 Run the named tests and display a summary of result. Tests will be run
516 Test results will be added to the supplied L<TAP::Parser::Aggregator>.
517 C<aggregate_tests> may be called multiple times to run several sets of
518 tests. Multiple C<Test::Harness> instances may be used to pass results
519 to a single aggregator so that different parts of a complex test suite
520 may be run using different C<TAP::Harness> settings. This is useful, for
521 example, in the case where some tests should run in parallel but others
522 are unsuitable for parallel execution.
524 my $formatter = TAP::Formatter::Console->new;
525 my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
526 my $par_harness = TAP::Harness->new( { formatter => $formatter,
528 my $aggregator = TAP::Parser::Aggregator->new;
530 $aggregator->start();
531 $ser_harness->aggregate_tests( $aggregator, @ser_tests );
532 $par_harness->aggregate_tests( $aggregator, @par_tests );
534 $formatter->summary( $aggregator );
536 Note that for simpler testing requirements it will often be possible to
537 replace the above code with a single call to C<runtests>.
539 Each elements of the @tests array is either
543 =item * the file name of a test script to run
545 =item * a reference to a [ file name, display name ] array
549 When you supply a separate display name it becomes possible to run a
550 test more than once; the display name is effectively the alias by which
551 the test is known inside the harness. The harness doesn't care if it
552 runs the same script more than once when each invocation uses a
557 sub aggregate_tests {
558 my ( $self, $aggregate, @tests ) = @_;
560 my $jobs = $self->jobs;
561 my $scheduler = $self->make_scheduler(@tests);
564 local $ENV{HARNESS_IS_VERBOSE} = 1
565 if $self->formatter->verbosity > 0;
567 # Formatter gets only names.
568 $self->formatter->prepare( map { $_->description } $scheduler->get_all );
570 if ( $self->jobs > 1 ) {
572 $self->_aggregate_forked( $aggregate, $scheduler );
575 $self->_aggregate_parallel( $aggregate, $scheduler );
579 $self->_aggregate_single( $aggregate, $scheduler );
585 sub _add_descriptions {
588 # First transformation: turn scalars into single element arrays
589 my @tests = map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
591 # Work out how many different extensions we have
593 for my $test (@tests) {
594 $ext{$1}++ if $test->[0] =~ /\.(\w+)$/;
597 for my $test (@tests) {
599 $test->[1] = $test->[0];
600 $test->[1] =~ s/\.\w+$//
607 =head3 C<make_scheduler>
609 Called by the harness when it needs to create a
610 L<TAP::Parser::Scheduler>. Override in a subclass to provide an
611 alternative scheduler. C<make_scheduler> is passed the list of tests
612 that was passed to C<aggregate_tests>.
617 my ( $self, @tests ) = @_;
618 return TAP::Parser::Scheduler->new(
619 tests => [ $self->_add_descriptions(@tests) ],
620 rules => $self->rules
626 Returns the number of concurrent test runs the harness is handling. For the default
627 harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
628 will override this to return the number of jobs it is handling.
632 If true the harness will attempt to fork and run the parser for each
633 test in a separate process. Currently this option requires
634 L<Parallel::Iterator> to be installed.
638 ##############################################################################
642 C<TAP::Harness> is designed to be (mostly) easy to subclass. If you don't
643 like how a particular feature functions, just override the desired methods.
647 TODO: This is out of date
649 The following methods are ones you may wish to override if you want to
650 subclass C<TAP::Harness>.
654 $harness->summary( \%args );
656 C<summary> prints the summary report after all tests are run. The argument is
657 a hashref with the following keys:
663 This is created with C<< Benchmark->new >> and it the time the tests started.
664 You can print a useful summary time, if desired, with:
666 $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' ));
670 This is an array reference of all test names. To get the L<TAP::Parser>
671 object for individual tests:
673 my $aggregate = $args->{aggregate};
674 my $tests = $args->{tests};
676 for my $name ( @$tests ) {
677 my ($parser) = $aggregate->parsers($test);
678 ... do something with $parser
681 This is a bit clunky and will be cleaned up in a later release.
687 sub _get_parser_args {
688 my ( $self, $job ) = @_;
689 my $test_prog = $job->filename;
692 @switches = $self->lib if $self->lib;
693 push @switches => $self->switches if $self->switches;
694 $args{switches} = \@switches;
695 $args{spool} = $self->_open_spool($test_prog);
696 $args{merge} = $self->merge;
697 $args{ignore_exit} = $self->ignore_exit;
699 if ( my $exec = $self->exec ) {
701 = ref $exec eq 'CODE'
702 ? $exec->( $self, $test_prog )
703 : [ @$exec, $test_prog ];
704 $args{source} = $test_prog unless $args{exec};
707 $args{source} = $test_prog;
710 if ( defined( my $test_args = $self->test_args ) ) {
711 $args{test_args} = $test_args;
717 =head3 C<make_parser>
719 Make a new parser and display formatter session. Typically used and/or
720 overridden in subclasses.
722 my ( $parser, $session ) = $harness->make_parser;
728 my ( $self, $job ) = @_;
730 my $args = $self->_get_parser_args($job);
731 $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
732 my $parser = TAP::Parser->new($args);
734 $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
735 my $session = $self->formatter->open_test( $job->description, $parser );
737 return ( $parser, $session );
740 =head3 C<finish_parser>
742 Terminate use of a parser. Typically used and/or overridden in
743 subclasses. The parser isn't destroyed as a result of this.
748 my ( $self, $parser, $session ) = @_;
750 $session->close_test;
751 $self->_close_spool($parser);
760 if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
762 my $spool = File::Spec->catfile( $spool_dir, $test );
765 my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
766 my $path = File::Spec->catpath( $vol, $dir, '' );
767 eval { mkpath($path) };
768 $self->_croak($@) if $@;
770 my $spool_handle = IO::Handle->new;
771 open( $spool_handle, ">$spool" )
772 or $self->_croak(" Can't write $spool ( $! ) ");
774 return $spool_handle;
784 if ( my $spool_handle = $parser->delete_spool ) {
786 or $self->_croak(" Error closing TAP spool file( $! ) \n ");
793 my ( $self, $message ) = @_;
795 $message = $self->_error;
797 $self->SUPER::_croak($message);
804 If you like the C<prove> utility and L<TAP::Parser> but you want your
805 own harness, all you need to do is write one and provide C<new> and
806 C<runtests> methods. Then you can use the C<prove> utility like so:
808 prove --harness My::Test::Harness
810 Note that while C<prove> accepts a list of tests (or things to be
811 tested), C<new> has a fairly rich set of arguments. You'll probably want
812 to read over this code carefully to see how all of them are being used.
822 # vim:ts=4:sw=4:et:sta