12 use vars qw($VERSION @ISA);
18 TAP::Harness - Run test scripts with statistics
28 $ENV{HARNESS_ACTIVE} = 1;
29 $ENV{HARNESS_VERSION} = $VERSION;
34 delete $ENV{HARNESS_ACTIVE};
35 delete $ENV{HARNESS_VERSION};
40 This is a simple test harness which allows tests to be run and results
41 automatically aggregated and output to STDOUT.
46 my $harness = TAP::Harness->new( \%args );
47 $harness->runtests(@tests);
56 return $self->{error} unless @_;
57 $self->{error} = shift;
63 directives verbosity timer failures comments errors stdout color
69 my ( $self, $libs ) = @_;
70 $libs = [$libs] unless 'ARRAY' eq ref $libs;
72 return [ map {"-I$_"} @$libs ];
74 switches => sub { shift; shift },
75 exec => sub { shift; shift },
76 merge => sub { shift; shift },
77 aggregator_class => sub { shift; shift },
78 formatter_class => sub { shift; shift },
79 multiplexer_class => sub { shift; shift },
80 parser_class => sub { shift; shift },
81 scheduler_class => sub { shift; shift },
82 formatter => sub { shift; shift },
83 jobs => 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', 'blib/arch' ],
138 my $harness = TAP::Harness->new( \%args );
140 The constructor returns a new C<TAP::Harness> object. It accepts an
141 optional 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.
154 -3 silent Suppress everything.
158 Append run time for each test to output. Uses L<Time::HiRes> if
163 Show test failures (this is a no-op if C<verbose> is selected).
167 Show test comments (this is a no-op if C<verbose> is selected).
169 =item * C<show_count>
171 Update the running test count during testing.
175 Set to a true value to normalize the TAP that is emitted in verbose modes.
179 Accepts a scalar value or array ref of scalar values indicating which
180 paths to allowed libraries should be included if Perl tests are
181 executed. Naturally, this only makes sense in the context of tests
186 Accepts a scalar value or array ref of scalar values indicating which
187 switches should be included if Perl tests are executed. Naturally, this
188 only makes sense in the context of tests written in Perl.
192 A reference to an C<@INC> style array of arguments to be passed to each
197 Attempt to produce color output.
201 Typically, Perl tests are run through this. However, anything which
202 spits out TAP is fine. You can use this argument to specify the name of
203 the program (and optional switches) to run your tests with:
205 exec => ['/usr/bin/ruby', '-w']
207 You can also pass a subroutine reference in order to determine and
208 return the proper program to run based on a given test script. The
209 subroutine reference should expect the TAP::Harness object itself as the
210 first argument, and the file name as the second argument. It should
211 return an array reference containing the command to be run and including
212 the test file name. It can also simply return C<undef>, in which case
213 TAP::Harness will fall back on executing the test script in Perl:
216 my ( $harness, $test_file ) = @_;
218 # Let Perl tests run.
219 return undef if $test_file =~ /[.]t$/;
220 return [ qw( /usr/bin/ruby -w ), $test_file ]
221 if $test_file =~ /[.]rb$/;
224 If the subroutine returns a scalar with a newline or a filehandle, it
225 will be interpreted as raw TAP or as a TAP stream, respectively.
229 If C<merge> is true the harness will create parsers that merge STDOUT
230 and STDERR together for any processes they start.
232 =item * C<aggregator_class>
234 The name of the class to use to aggregate test results. The default is
235 L<TAP::Parser::Aggregator>.
237 =item * C<formatter_class>
239 The name of the class to use to format output. The default is
240 L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output
243 =item * C<multiplexer_class>
245 The name of the class to use to multiplex tests during parallel testing.
246 The default is L<TAP::Parser::Multiplexer>.
248 =item * C<parser_class>
250 The name of the class to use to parse TAP. The default is
253 =item * C<scheduler_class>
255 The name of the class to use to schedule test execution. The default is
256 L<TAP::Parser::Scheduler>.
260 If set C<formatter> must be an object that is capable of formatting the
261 TAP output. See L<TAP::Formatter::Console> for an example.
265 If parse errors are found in the TAP output, a note of this will be
266 made in the summary report. To see all of the parse errors, set this
271 =item * C<directives>
273 If set to a true value, only test results with directives will be
274 displayed. This overrides other settings such as C<verbose> or
277 =item * C<ignore_exit>
279 If set to a true value instruct C<TAP::Parser> to ignore exit and wait
280 status from test scripts.
284 The maximum number of parallel tests to run at any time. Which tests
285 can be run in parallel is controlled by C<rules>. The default is to
286 run only one test at a time.
290 A reference to a hash of rules that control which tests may be
291 executed in parallel. This is an experimental feature and the
292 interface may change.
296 { seq => '../ext/DB_File/t/*' },
297 { seq => '../ext/IO_Compress_Zlib/t/*' },
298 { seq => '../lib/CPANPLUS/*' },
299 { seq => '../lib/ExtUtils/t/*' },
307 A filehandle for catching standard output.
311 Any keys for which the value is C<undef> will be ignored.
315 # new supplied by TAP::Base
318 my @legal_callback = qw(
326 my %default_class = (
327 aggregator_class => 'TAP::Parser::Aggregator',
328 formatter_class => 'TAP::Formatter::Console',
329 multiplexer_class => 'TAP::Parser::Multiplexer',
330 parser_class => 'TAP::Parser',
331 scheduler_class => 'TAP::Parser::Scheduler',
335 my ( $self, $arg_for ) = @_;
338 $self->SUPER::_initialize( $arg_for, \@legal_callback );
339 my %arg_for = %$arg_for; # force a shallow copy
341 for my $name ( sort keys %VALIDATION_FOR ) {
342 my $property = delete $arg_for{$name};
343 if ( defined $property ) {
344 my $validate = $VALIDATION_FOR{$name};
346 my $value = $self->$validate($property);
347 if ( $self->_error ) {
350 $self->$name($value);
354 $self->jobs(1) unless defined $self->jobs;
356 local $default_class{formatter_class} = 'TAP::Formatter::File'
357 unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY};
359 while ( my ( $attr, $class ) = each %default_class ) {
360 $self->$attr( $self->$attr() || $class );
363 unless ( $self->formatter ) {
365 # This is a little bodge to preserve legacy behaviour. It's
366 # pretty horrible that we know which args are destined for
368 my %formatter_args = ( jobs => $self->jobs );
369 for my $name (@FORMATTER_ARGS) {
370 if ( defined( my $property = delete $arg_for{$name} ) ) {
371 $formatter_args{$name} = $property;
376 $self->_construct( $self->formatter_class, \%formatter_args )
380 if ( my @props = sort keys %arg_for ) {
381 $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
388 ##############################################################################
390 =head2 Instance Methods
394 $harness->runtests(@tests);
396 Accepts and array of C<@tests> to be run. This should generally be the
397 names of test files, but this is not required. Each element in C<@tests>
398 will be passed to C<TAP::Parser::new()> as a C<source>. See
399 L<TAP::Parser> for more information.
401 It is possible to provide aliases that will be displayed in place of the
402 test name by supplying the test as a reference to an array containing
403 C<< [ $test, $alias ] >>:
405 $harness->runtests( [ 't/foo.t', 'Foo Once' ],
406 [ 't/foo.t', 'Foo Twice' ] );
408 Normally it is an error to attempt to run the same test twice. Aliases
409 allow you to overcome this limitation by giving each run of the test a
412 Tests will be run in the order found.
414 If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
415 should name a directory into which a copy of the raw TAP for each test
416 will be written. TAP is written to files named for each test.
417 Subdirectories will be created as needed.
419 Returns a L<TAP::Parser::Aggregator> containing the test results.
424 my ( $self, @tests ) = @_;
426 my $aggregate = $self->_construct( $self->aggregator_class );
428 $self->_make_callback( 'before_runtests', $aggregate );
430 $self->aggregate_tests( $aggregate, @tests );
432 $self->summary($aggregate);
433 $self->_make_callback( 'after_runtests', $aggregate );
440 Output the summary for a TAP::Parser::Aggregator.
445 my ( $self, $aggregate ) = @_;
446 $self->formatter->summary($aggregate);
450 my ( $self, $aggregate, $job, $parser ) = @_;
452 $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
453 $aggregate->add( $job->description, $parser );
457 my ( $self, $result ) = @_;
458 my $explanation = $result->explanation;
459 die "FAILED--Further testing stopped"
460 . ( $explanation ? ": $explanation\n" : ".\n" );
463 sub _aggregate_parallel {
464 my ( $self, $aggregate, $scheduler ) = @_;
466 my $jobs = $self->jobs;
467 my $mux = $self->_construct( $self->multiplexer_class );
471 # Keep multiplexer topped up
473 while ( $mux->parsers < $jobs ) {
474 my $job = $scheduler->get_job;
476 # If we hit a spinner stop filling and start running.
477 last FILL if !defined $job || $job->is_spinner;
479 my ( $parser, $session ) = $self->make_parser($job);
480 $mux->add( $parser, [ $session, $job ] );
483 if ( my ( $parser, $stash, $result ) = $mux->next ) {
484 my ( $session, $job ) = @$stash;
485 if ( defined $result ) {
486 $session->result($result);
487 $self->_bailout($result) if $result->is_bailout;
491 # End of parser. Automatically removed from the mux.
492 $self->finish_parser( $parser, $session );
493 $self->_after_test( $aggregate, $job, $parser );
503 sub _aggregate_single {
504 my ( $self, $aggregate, $scheduler ) = @_;
507 while ( my $job = $scheduler->get_job ) {
508 next JOB if $job->is_spinner;
510 my ( $parser, $session ) = $self->make_parser($job);
512 while ( defined( my $result = $parser->next ) ) {
513 $session->result($result);
514 if ( $result->is_bailout ) {
516 # Keep reading until input is exhausted in the hope
517 # of allowing any pending diagnostics to show up.
518 1 while $parser->next;
519 $self->_bailout($result);
523 $self->finish_parser( $parser, $session );
524 $self->_after_test( $aggregate, $job, $parser );
531 =head3 C<aggregate_tests>
533 $harness->aggregate_tests( $aggregate, @tests );
535 Run the named tests and display a summary of result. Tests will be run
538 Test results will be added to the supplied L<TAP::Parser::Aggregator>.
539 C<aggregate_tests> may be called multiple times to run several sets of
540 tests. Multiple C<Test::Harness> instances may be used to pass results
541 to a single aggregator so that different parts of a complex test suite
542 may be run using different C<TAP::Harness> settings. This is useful, for
543 example, in the case where some tests should run in parallel but others
544 are unsuitable for parallel execution.
546 my $formatter = TAP::Formatter::Console->new;
547 my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
548 my $par_harness = TAP::Harness->new(
549 { formatter => $formatter,
553 my $aggregator = TAP::Parser::Aggregator->new;
555 $aggregator->start();
556 $ser_harness->aggregate_tests( $aggregator, @ser_tests );
557 $par_harness->aggregate_tests( $aggregator, @par_tests );
559 $formatter->summary($aggregator);
561 Note that for simpler testing requirements it will often be possible to
562 replace the above code with a single call to C<runtests>.
564 Each elements of the @tests array is either
568 =item * the file name of a test script to run
570 =item * a reference to a [ file name, display name ] array
574 When you supply a separate display name it becomes possible to run a
575 test more than once; the display name is effectively the alias by which
576 the test is known inside the harness. The harness doesn't care if it
577 runs the same script more than once when each invocation uses a
582 sub aggregate_tests {
583 my ( $self, $aggregate, @tests ) = @_;
585 my $jobs = $self->jobs;
586 my $scheduler = $self->make_scheduler(@tests);
589 local $ENV{HARNESS_IS_VERBOSE} = 1
590 if $self->formatter->verbosity > 0;
592 # Formatter gets only names.
593 $self->formatter->prepare( map { $_->description } $scheduler->get_all );
595 if ( $self->jobs > 1 ) {
596 $self->_aggregate_parallel( $aggregate, $scheduler );
599 $self->_aggregate_single( $aggregate, $scheduler );
605 sub _add_descriptions {
608 # Turn unwrapped scalars into anonymous arrays and copy the name as
609 # the description for tests that have only a name.
610 return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ }
611 map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
614 =head3 C<make_scheduler>
616 Called by the harness when it needs to create a
617 L<TAP::Parser::Scheduler>. Override in a subclass to provide an
618 alternative scheduler. C<make_scheduler> is passed the list of tests
619 that was passed to C<aggregate_tests>.
624 my ( $self, @tests ) = @_;
625 return $self->_construct(
626 $self->scheduler_class,
627 tests => [ $self->_add_descriptions(@tests) ],
628 rules => $self->rules
634 Gets or sets the number of concurrent test runs the harness is
635 handling. By default, this value is 1 -- for parallel testing, this
636 should be set higher.
640 ##############################################################################
644 C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
645 don't like how a particular feature functions, just override the
650 TODO: This is out of date
652 The following methods are ones you may wish to override if you want to
653 subclass C<TAP::Harness>.
657 $harness->summary( \%args );
659 C<summary> prints the summary report after all tests are run. The
660 argument is a hashref with the following keys:
666 This is created with C<< Benchmark->new >> and it the time the tests
667 started. You can print a useful summary time, if desired, with:
670 timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
674 This is an array reference of all test names. To get the L<TAP::Parser>
675 object for individual tests:
677 my $aggregate = $args->{aggregate};
678 my $tests = $args->{tests};
680 for my $name ( @$tests ) {
681 my ($parser) = $aggregate->parsers($test);
682 ... do something with $parser
685 This is a bit clunky and will be cleaned up in a later release.
691 sub _get_parser_args {
692 my ( $self, $job ) = @_;
693 my $test_prog = $job->filename;
696 @switches = $self->lib if $self->lib;
697 push @switches => $self->switches if $self->switches;
698 $args{switches} = \@switches;
699 $args{spool} = $self->_open_spool($test_prog);
700 $args{merge} = $self->merge;
701 $args{ignore_exit} = $self->ignore_exit;
703 if ( my $exec = $self->exec ) {
705 = ref $exec eq 'CODE'
706 ? $exec->( $self, $test_prog )
707 : [ @$exec, $test_prog ];
708 if ( not defined $args{exec} ) {
709 $args{source} = $test_prog;
711 elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
712 $args{source} = delete $args{exec};
716 $args{source} = $test_prog;
719 if ( defined( my $test_args = $self->test_args ) ) {
720 $args{test_args} = $test_args;
726 =head3 C<make_parser>
728 Make a new parser and display formatter session. Typically used and/or
729 overridden in subclasses.
731 my ( $parser, $session ) = $harness->make_parser;
736 my ( $self, $job ) = @_;
738 my $args = $self->_get_parser_args($job);
739 $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
740 my $parser = $self->_construct( $self->parser_class, $args );
742 $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
743 my $session = $self->formatter->open_test( $job->description, $parser );
745 return ( $parser, $session );
748 =head3 C<finish_parser>
750 Terminate use of a parser. Typically used and/or overridden in
751 subclasses. The parser isn't destroyed as a result of this.
756 my ( $self, $parser, $session ) = @_;
758 $session->close_test;
759 $self->_close_spool($parser);
768 if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
770 my $spool = File::Spec->catfile( $spool_dir, $test );
773 my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
774 my $path = File::Spec->catpath( $vol, $dir, '' );
775 eval { mkpath($path) };
776 $self->_croak($@) if $@;
778 my $spool_handle = IO::Handle->new;
779 open( $spool_handle, ">$spool" )
780 or $self->_croak(" Can't write $spool ( $! ) ");
782 return $spool_handle;
792 if ( my $spool_handle = $parser->delete_spool ) {
794 or $self->_croak(" Error closing TAP spool file( $! ) \n ");
801 my ( $self, $message ) = @_;
803 $message = $self->_error;
805 $self->SUPER::_croak($message);
812 If you like the C<prove> utility and L<TAP::Parser> but you want your
813 own harness, all you need to do is write one and provide C<new> and
814 C<runtests> methods. Then you can use the C<prove> utility like so:
816 prove --harness My::Test::Harness
818 Note that while C<prove> accepts a list of tests (or things to be
819 tested), C<new> has a fairly rich set of arguments. You'll probably want
820 to read over this code carefully to see how all of them are being used.
830 # vim:ts=4:sw=4:et:sta