1package TAP::Harness; 2 3use strict; 4use warnings; 5use Carp; 6 7use File::Spec; 8use File::Path; 9use IO::Handle; 10 11use base 'TAP::Base'; 12 13=head1 NAME 14 15TAP::Harness - Run test scripts with statistics 16 17=head1 VERSION 18 19Version 3.42 20 21=cut 22 23our $VERSION = '3.42'; 24 25$ENV{HARNESS_ACTIVE} = 1; 26$ENV{HARNESS_VERSION} = $VERSION; 27 28END { 29 30 # For VMS. 31 delete $ENV{HARNESS_ACTIVE}; 32 delete $ENV{HARNESS_VERSION}; 33} 34 35=head1 DESCRIPTION 36 37This is a simple test harness which allows tests to be run and results 38automatically aggregated and output to STDOUT. 39 40=head1 SYNOPSIS 41 42 use TAP::Harness; 43 my $harness = TAP::Harness->new( \%args ); 44 $harness->runtests(@tests); 45 46=cut 47 48my %VALIDATION_FOR; 49my @FORMATTER_ARGS; 50 51sub _error { 52 my $self = shift; 53 return $self->{error} unless @_; 54 $self->{error} = shift; 55} 56 57BEGIN { 58 59 @FORMATTER_ARGS = qw( 60 directives verbosity timer failures comments errors stdout color 61 show_count normalize 62 ); 63 64 %VALIDATION_FOR = ( 65 lib => sub { 66 my ( $self, $libs ) = @_; 67 $libs = [$libs] unless 'ARRAY' eq ref $libs; 68 69 return [ map {"-I$_"} @$libs ]; 70 }, 71 switches => sub { shift; shift }, 72 exec => sub { shift; shift }, 73 merge => sub { shift; shift }, 74 aggregator_class => sub { shift; shift }, 75 formatter_class => sub { shift; shift }, 76 multiplexer_class => sub { shift; shift }, 77 parser_class => sub { shift; shift }, 78 scheduler_class => sub { shift; shift }, 79 formatter => sub { shift; shift }, 80 jobs => sub { shift; shift }, 81 test_args => sub { shift; shift }, 82 ignore_exit => sub { shift; shift }, 83 rules => sub { shift; shift }, 84 rulesfile => sub { shift; shift }, 85 sources => sub { shift; shift }, 86 version => sub { shift; shift }, 87 trap => sub { shift; shift }, 88 ); 89 90 for my $method ( sort keys %VALIDATION_FOR ) { 91 no strict 'refs'; 92 if ( $method eq 'lib' || $method eq 'switches' ) { 93 *{$method} = sub { 94 my $self = shift; 95 unless (@_) { 96 $self->{$method} ||= []; 97 return wantarray 98 ? @{ $self->{$method} } 99 : $self->{$method}; 100 } 101 $self->_croak("Too many arguments to method '$method'") 102 if @_ > 1; 103 my $args = shift; 104 $args = [$args] unless ref $args; 105 $self->{$method} = $args; 106 return $self; 107 }; 108 } 109 else { 110 *{$method} = sub { 111 my $self = shift; 112 return $self->{$method} unless @_; 113 $self->{$method} = shift; 114 }; 115 } 116 } 117 118 for my $method (@FORMATTER_ARGS) { 119 no strict 'refs'; 120 *{$method} = sub { 121 my $self = shift; 122 return $self->formatter->$method(@_); 123 }; 124 } 125} 126 127############################################################################## 128 129=head1 METHODS 130 131=head2 Class Methods 132 133=head3 C<new> 134 135 my %args = ( 136 verbosity => 1, 137 lib => [ 'lib', 'blib/lib', 'blib/arch' ], 138 ) 139 my $harness = TAP::Harness->new( \%args ); 140 141The constructor returns a new C<TAP::Harness> object. It accepts an 142optional hashref whose allowed keys are: 143 144=over 4 145 146=item * C<verbosity> 147 148Set the verbosity level: 149 150 1 verbose Print individual test results to STDOUT. 151 0 normal 152 -1 quiet Suppress some test output (mostly failures 153 while tests are running). 154 -2 really quiet Suppress everything but the tests summary. 155 -3 silent Suppress everything. 156 157=item * C<timer> 158 159Append run time for each test to output. Uses L<Time::HiRes> if 160available. 161 162=item * C<failures> 163 164Show test failures (this is a no-op if C<verbose> is selected). 165 166=item * C<comments> 167 168Show test comments (this is a no-op if C<verbose> is selected). 169 170=item * C<show_count> 171 172Update the running test count during testing. 173 174=item * C<normalize> 175 176Set to a true value to normalize the TAP that is emitted in verbose modes. 177 178=item * C<lib> 179 180Accepts a scalar value or array ref of scalar values indicating which 181paths to allowed libraries should be included if Perl tests are 182executed. Naturally, this only makes sense in the context of tests 183written in Perl. 184 185=item * C<switches> 186 187Accepts a scalar value or array ref of scalar values indicating which 188switches should be included if Perl tests are executed. Naturally, this 189only makes sense in the context of tests written in Perl. 190 191=item * C<test_args> 192 193A reference to an C<@INC> style array of arguments to be passed to each 194test program. 195 196 test_args => ['foo', 'bar'], 197 198if you want to pass different arguments to each test then you should 199pass a hash of arrays, keyed by the alias for each test: 200 201 test_args => { 202 my_test => ['foo', 'bar'], 203 other_test => ['baz'], 204 } 205 206=item * C<color> 207 208Attempt to produce color output. 209 210=item * C<exec> 211 212Typically, Perl tests are run through this. However, anything which 213spits out TAP is fine. You can use this argument to specify the name of 214the program (and optional switches) to run your tests with: 215 216 exec => ['/usr/bin/ruby', '-w'] 217 218You can also pass a subroutine reference in order to determine and 219return the proper program to run based on a given test script. The 220subroutine reference should expect the TAP::Harness object itself as the 221first argument, and the file name as the second argument. It should 222return an array reference containing the command to be run and including 223the test file name. It can also simply return C<undef>, in which case 224TAP::Harness will fall back on executing the test script in Perl: 225 226 exec => sub { 227 my ( $harness, $test_file ) = @_; 228 229 # Let Perl tests run. 230 return undef if $test_file =~ /[.]t$/; 231 return [ qw( /usr/bin/ruby -w ), $test_file ] 232 if $test_file =~ /[.]rb$/; 233 } 234 235If the subroutine returns a scalar with a newline or a filehandle, it 236will be interpreted as raw TAP or as a TAP stream, respectively. 237 238=item * C<merge> 239 240If C<merge> is true the harness will create parsers that merge STDOUT 241and STDERR together for any processes they start. 242 243=item * C<sources> 244 245I<NEW to 3.18>. 246 247If set, C<sources> must be a hashref containing the names of the 248L<TAP::Parser::SourceHandler>s to load and/or configure. The values are a 249hash of configuration that will be accessible to the source handlers via 250L<TAP::Parser::Source/config_for>. 251 252For example: 253 254 sources => { 255 Perl => { exec => '/path/to/custom/perl' }, 256 File => { extensions => [ '.tap', '.txt' ] }, 257 MyCustom => { some => 'config' }, 258 } 259 260The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters 261are handled. 262 263For more details, see the C<sources> parameter in L<TAP::Parser/new>, 264L<TAP::Parser::Source>, and L<TAP::Parser::IteratorFactory>. 265 266=item * C<aggregator_class> 267 268The name of the class to use to aggregate test results. The default is 269L<TAP::Parser::Aggregator>. 270 271=item * C<version> 272 273I<NEW to 3.22>. 274 275Assume this TAP version for L<TAP::Parser> instead of default TAP 276version 12. 277 278=item * C<formatter_class> 279 280The name of the class to use to format output. The default is 281L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output 282isn't a TTY. 283 284=item * C<multiplexer_class> 285 286The name of the class to use to multiplex tests during parallel testing. 287The default is L<TAP::Parser::Multiplexer>. 288 289=item * C<parser_class> 290 291The name of the class to use to parse TAP. The default is 292L<TAP::Parser>. 293 294=item * C<scheduler_class> 295 296The name of the class to use to schedule test execution. The default is 297L<TAP::Parser::Scheduler>. 298 299=item * C<formatter> 300 301If set C<formatter> must be an object that is capable of formatting the 302TAP output. See L<TAP::Formatter::Console> for an example. 303 304=item * C<errors> 305 306If parse errors are found in the TAP output, a note of this will be 307made in the summary report. To see all of the parse errors, set this 308argument to true: 309 310 errors => 1 311 312=item * C<directives> 313 314If set to a true value, only test results with directives will be 315displayed. This overrides other settings such as C<verbose> or 316C<failures>. 317 318=item * C<ignore_exit> 319 320If set to a true value instruct C<TAP::Parser> to ignore exit and wait 321status from test scripts. 322 323=item * C<jobs> 324 325The maximum number of parallel tests to run at any time. Which tests 326can be run in parallel is controlled by C<rules>. The default is to 327run only one test at a time. 328 329=item * C<rules> 330 331A reference to a hash of rules that control which tests may be executed in 332parallel. If no rules are declared and L<CPAN::Meta::YAML> is available, 333C<TAP::Harness> attempts to load rules from a YAML file specified by the 334C<rulesfile> parameter. If no rules file exists, the default is for all 335tests to be eligible to be run in parallel. 336 337Here some simple examples. For the full details of the data structure 338and the related glob-style pattern matching, see 339L<TAP::Parser::Scheduler/"Rules data structure">. 340 341 # Run all tests in sequence, except those starting with "p" 342 $harness->rules({ 343 par => 't/p*.t' 344 }); 345 346 # Equivalent YAML file 347 --- 348 par: t/p*.t 349 350 # Run all tests in parallel, except those starting with "p" 351 $harness->rules({ 352 seq => [ 353 { seq => 't/p*.t' }, 354 { par => '**' }, 355 ], 356 }); 357 358 # Equivalent YAML file 359 --- 360 seq: 361 - seq: t/p*.t 362 - par: ** 363 364 # Run some startup tests in sequence, then some parallel tests than some 365 # teardown tests in sequence. 366 $harness->rules({ 367 seq => [ 368 { seq => 't/startup/*.t' }, 369 { par => ['t/a/*.t','t/b/*.t','t/c/*.t'], } 370 { seq => 't/shutdown/*.t' }, 371 ], 372 373 }); 374 375 # Equivalent YAML file 376 --- 377 seq: 378 - seq: t/startup/*.t 379 - par: 380 - t/a/*.t 381 - t/b/*.t 382 - t/c/*.t 383 - seq: t/shutdown/*.t 384 385This is an experimental feature and the interface may change. 386 387=item * C<rulesfiles> 388 389This specifies where to find a YAML file of test scheduling rules. If not 390provided, it looks for a default file to use. It first checks for a file given 391in the C<HARNESS_RULESFILE> environment variable, then it checks for 392F<testrules.yml> and then F<t/testrules.yml>. 393 394=item * C<stdout> 395 396A filehandle for catching standard output. 397 398=item * C<trap> 399 400Attempt to print summary information if run is interrupted by 401SIGINT (Ctrl-C). 402 403=back 404 405Any keys for which the value is C<undef> will be ignored. 406 407=cut 408 409# new supplied by TAP::Base 410 411{ 412 my @legal_callback = qw( 413 parser_args 414 made_parser 415 before_runtests 416 after_runtests 417 after_test 418 ); 419 420 my %default_class = ( 421 aggregator_class => 'TAP::Parser::Aggregator', 422 formatter_class => 'TAP::Formatter::Console', 423 multiplexer_class => 'TAP::Parser::Multiplexer', 424 parser_class => 'TAP::Parser', 425 scheduler_class => 'TAP::Parser::Scheduler', 426 ); 427 428 sub _initialize { 429 my ( $self, $arg_for ) = @_; 430 $arg_for ||= {}; 431 432 $self->SUPER::_initialize( $arg_for, \@legal_callback ); 433 my %arg_for = %$arg_for; # force a shallow copy 434 435 for my $name ( sort keys %VALIDATION_FOR ) { 436 my $property = delete $arg_for{$name}; 437 if ( defined $property ) { 438 my $validate = $VALIDATION_FOR{$name}; 439 440 my $value = $self->$validate($property); 441 if ( $self->_error ) { 442 $self->_croak; 443 } 444 $self->$name($value); 445 } 446 } 447 448 $self->jobs(1) unless defined $self->jobs; 449 450 if ( ! defined $self->rules ) { 451 $self->_maybe_load_rulesfile; 452 } 453 454 local $default_class{formatter_class} = 'TAP::Formatter::File' 455 unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY}; 456 457 while ( my ( $attr, $class ) = each %default_class ) { 458 $self->$attr( $self->$attr() || $class ); 459 } 460 461 unless ( $self->formatter ) { 462 463 # This is a little bodge to preserve legacy behaviour. It's 464 # pretty horrible that we know which args are destined for 465 # the formatter. 466 my %formatter_args = ( jobs => $self->jobs ); 467 for my $name (@FORMATTER_ARGS) { 468 if ( defined( my $property = delete $arg_for{$name} ) ) { 469 $formatter_args{$name} = $property; 470 } 471 } 472 473 $self->formatter( 474 $self->_construct( $self->formatter_class, \%formatter_args ) 475 ); 476 } 477 478 if ( my @props = sort keys %arg_for ) { 479 $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); 480 } 481 482 return $self; 483 } 484 485 sub _maybe_load_rulesfile { 486 my ($self) = @_; 487 488 my ($rulesfile) = defined $self->rulesfile ? $self->rulesfile : 489 defined($ENV{HARNESS_RULESFILE}) ? $ENV{HARNESS_RULESFILE} : 490 grep { -r } qw(./testrules.yml t/testrules.yml); 491 492 if ( defined $rulesfile && -r $rulesfile ) { 493 if ( ! eval { require CPAN::Meta::YAML; 1} ) { 494 warn "CPAN::Meta::YAML required to process $rulesfile" ; 495 return; 496 } 497 my $layer = $] lt "5.008" ? "" : ":encoding(UTF-8)"; 498 open my $fh, "<$layer", $rulesfile 499 or die "Couldn't open $rulesfile: $!"; 500 my $yaml_text = do { local $/; <$fh> }; 501 my $yaml = CPAN::Meta::YAML->read_string($yaml_text) 502 or die CPAN::Meta::YAML->errstr; 503 $self->rules( $yaml->[0] ); 504 } 505 return; 506 } 507} 508 509############################################################################## 510 511=head2 Instance Methods 512 513=head3 C<runtests> 514 515 $harness->runtests(@tests); 516 517Accepts an array of C<@tests> to be run. This should generally be the 518names of test files, but this is not required. Each element in C<@tests> 519will be passed to C<TAP::Parser::new()> as a C<source>. See 520L<TAP::Parser> for more information. 521 522It is possible to provide aliases that will be displayed in place of the 523test name by supplying the test as a reference to an array containing 524C<< [ $test, $alias ] >>: 525 526 $harness->runtests( [ 't/foo.t', 'Foo Once' ], 527 [ 't/foo.t', 'Foo Twice' ] ); 528 529Normally it is an error to attempt to run the same test twice. Aliases 530allow you to overcome this limitation by giving each run of the test a 531unique name. 532 533Tests will be run in the order found. 534 535If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it 536should name a directory into which a copy of the raw TAP for each test 537will be written. TAP is written to files named for each test. 538Subdirectories will be created as needed. 539 540Returns a L<TAP::Parser::Aggregator> containing the test results. 541 542=cut 543 544sub runtests { 545 my ( $self, @tests ) = @_; 546 547 my $aggregate = $self->_construct( $self->aggregator_class ); 548 549 $self->_make_callback( 'before_runtests', $aggregate ); 550 $aggregate->start; 551 my $finish = sub { 552 my $interrupted = shift; 553 $aggregate->stop; 554 $self->summary( $aggregate, $interrupted ); 555 $self->_make_callback( 'after_runtests', $aggregate ); 556 }; 557 my $run = sub { 558 $self->aggregate_tests( $aggregate, @tests ); 559 $finish->(); 560 }; 561 562 if ( $self->trap ) { 563 local $SIG{INT} = sub { 564 print "\n"; 565 $finish->(1); 566 exit; 567 }; 568 $run->(); 569 } 570 else { 571 $run->(); 572 } 573 574 return $aggregate; 575} 576 577=head3 C<summary> 578 579 $harness->summary( $aggregator ); 580 581Output the summary for a L<TAP::Parser::Aggregator>. 582 583=cut 584 585sub summary { 586 my ( $self, @args ) = @_; 587 $self->formatter->summary(@args); 588} 589 590sub _after_test { 591 my ( $self, $aggregate, $job, $parser ) = @_; 592 593 $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); 594 $aggregate->add( $job->description, $parser ); 595} 596 597sub _bailout { 598 my ( $self, $result ) = @_; 599 my $explanation = $result->explanation; 600 die "FAILED--Further testing stopped" 601 . ( $explanation ? ": $explanation\n" : ".\n" ); 602} 603 604sub _aggregate_parallel { 605 my ( $self, $aggregate, $scheduler ) = @_; 606 607 my $jobs = $self->jobs; 608 my $mux = $self->_construct( $self->multiplexer_class ); 609 610 RESULT: { 611 612 # Keep multiplexer topped up 613 FILL: 614 while ( $mux->parsers < $jobs ) { 615 my $job = $scheduler->get_job; 616 617 # If we hit a spinner stop filling and start running. 618 last FILL if !defined $job || $job->is_spinner; 619 620 my ( $parser, $session ) = $self->make_parser($job); 621 $mux->add( $parser, [ $session, $job ] ); 622 } 623 624 if ( my ( $parser, $stash, $result ) = $mux->next ) { 625 my ( $session, $job ) = @$stash; 626 if ( defined $result ) { 627 $session->result($result); 628 $self->_bailout($result) if $result->is_bailout; 629 } 630 else { 631 632 # End of parser. Automatically removed from the mux. 633 $self->finish_parser( $parser, $session ); 634 $self->_after_test( $aggregate, $job, $parser ); 635 $job->finish; 636 } 637 redo RESULT; 638 } 639 } 640 641 return; 642} 643 644sub _aggregate_single { 645 my ( $self, $aggregate, $scheduler ) = @_; 646 647 JOB: 648 while ( my $job = $scheduler->get_job ) { 649 next JOB if $job->is_spinner; 650 651 my ( $parser, $session ) = $self->make_parser($job); 652 653 while ( defined( my $result = $parser->next ) ) { 654 $session->result($result); 655 if ( $result->is_bailout ) { 656 657 # Keep reading until input is exhausted in the hope 658 # of allowing any pending diagnostics to show up. 659 1 while $parser->next; 660 $self->_bailout($result); 661 } 662 } 663 664 $self->finish_parser( $parser, $session ); 665 $self->_after_test( $aggregate, $job, $parser ); 666 $job->finish; 667 } 668 669 return; 670} 671 672=head3 C<aggregate_tests> 673 674 $harness->aggregate_tests( $aggregate, @tests ); 675 676Run the named tests and display a summary of result. Tests will be run 677in the order found. 678 679Test results will be added to the supplied L<TAP::Parser::Aggregator>. 680C<aggregate_tests> may be called multiple times to run several sets of 681tests. Multiple C<Test::Harness> instances may be used to pass results 682to a single aggregator so that different parts of a complex test suite 683may be run using different C<TAP::Harness> settings. This is useful, for 684example, in the case where some tests should run in parallel but others 685are unsuitable for parallel execution. 686 687 my $formatter = TAP::Formatter::Console->new; 688 my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); 689 my $par_harness = TAP::Harness->new( 690 { formatter => $formatter, 691 jobs => 9 692 } 693 ); 694 my $aggregator = TAP::Parser::Aggregator->new; 695 696 $aggregator->start(); 697 $ser_harness->aggregate_tests( $aggregator, @ser_tests ); 698 $par_harness->aggregate_tests( $aggregator, @par_tests ); 699 $aggregator->stop(); 700 $formatter->summary($aggregator); 701 702Note that for simpler testing requirements it will often be possible to 703replace the above code with a single call to C<runtests>. 704 705Each element of the C<@tests> array is either: 706 707=over 708 709=item * the source name of a test to run 710 711=item * a reference to a [ source name, display name ] array 712 713=back 714 715In the case of a perl test suite, typically I<source names> are simply the file 716names of the test scripts to run. 717 718When you supply a separate display name it becomes possible to run a 719test more than once; the display name is effectively the alias by which 720the test is known inside the harness. The harness doesn't care if it 721runs the same test more than once when each invocation uses a 722different name. 723 724=cut 725 726sub aggregate_tests { 727 my ( $self, $aggregate, @tests ) = @_; 728 729 my $jobs = $self->jobs; 730 my $scheduler = $self->make_scheduler(@tests); 731 732 # #12458 733 local $ENV{HARNESS_IS_VERBOSE} = 1 734 if $self->formatter->verbosity > 0; 735 736 # Formatter gets only names. 737 $self->formatter->prepare( map { $_->description } $scheduler->get_all ); 738 739 if ( $self->jobs > 1 ) { 740 $self->_aggregate_parallel( $aggregate, $scheduler ); 741 } 742 else { 743 $self->_aggregate_single( $aggregate, $scheduler ); 744 } 745 746 return; 747} 748 749sub _add_descriptions { 750 my $self = shift; 751 752 # Turn unwrapped scalars into anonymous arrays and copy the name as 753 # the description for tests that have only a name. 754 return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ } 755 map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; 756} 757 758=head3 C<make_scheduler> 759 760Called by the harness when it needs to create a 761L<TAP::Parser::Scheduler>. Override in a subclass to provide an 762alternative scheduler. C<make_scheduler> is passed the list of tests 763that was passed to C<aggregate_tests>. 764 765=cut 766 767sub make_scheduler { 768 my ( $self, @tests ) = @_; 769 return $self->_construct( 770 $self->scheduler_class, 771 tests => [ $self->_add_descriptions(@tests) ], 772 rules => $self->rules 773 ); 774} 775 776=head3 C<jobs> 777 778Gets or sets the number of concurrent test runs the harness is 779handling. By default, this value is 1 -- for parallel testing, this 780should be set higher. 781 782=cut 783 784############################################################################## 785 786sub _get_parser_args { 787 my ( $self, $job ) = @_; 788 my $test_prog = $job->filename; 789 my %args = (); 790 791 $args{sources} = $self->sources if $self->sources; 792 793 my @switches; 794 @switches = $self->lib if $self->lib; 795 push @switches => $self->switches if $self->switches; 796 $args{switches} = \@switches; 797 $args{spool} = $self->_open_spool($test_prog); 798 $args{merge} = $self->merge; 799 $args{ignore_exit} = $self->ignore_exit; 800 $args{version} = $self->version if $self->version; 801 802 if ( my $exec = $self->exec ) { 803 $args{exec} 804 = ref $exec eq 'CODE' 805 ? $exec->( $self, $test_prog ) 806 : [ @$exec, $test_prog ]; 807 if ( not defined $args{exec} ) { 808 $args{source} = $test_prog; 809 } 810 elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) { 811 $args{source} = delete $args{exec}; 812 } 813 } 814 else { 815 $args{source} = $test_prog; 816 } 817 818 if ( defined( my $test_args = $self->test_args ) ) { 819 820 if ( ref($test_args) eq 'HASH' ) { 821 822 # different args for each test 823 if ( exists( $test_args->{ $job->description } ) ) { 824 $test_args = $test_args->{ $job->description }; 825 } 826 else { 827 $self->_croak( "TAP::Harness Can't find test_args for " 828 . $job->description ); 829 } 830 } 831 832 $args{test_args} = $test_args; 833 } 834 835 return \%args; 836} 837 838=head3 C<make_parser> 839 840Make a new parser and display formatter session. Typically used and/or 841overridden in subclasses. 842 843 my ( $parser, $session ) = $harness->make_parser; 844 845=cut 846 847sub make_parser { 848 my ( $self, $job ) = @_; 849 850 my $args = $self->_get_parser_args($job); 851 $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); 852 my $parser = $self->_construct( $self->parser_class, $args ); 853 854 $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); 855 my $session = $self->formatter->open_test( $job->description, $parser ); 856 857 return ( $parser, $session ); 858} 859 860=head3 C<finish_parser> 861 862Terminate use of a parser. Typically used and/or overridden in 863subclasses. The parser isn't destroyed as a result of this. 864 865=cut 866 867sub finish_parser { 868 my ( $self, $parser, $session ) = @_; 869 870 $session->close_test; 871 $self->_close_spool($parser); 872 873 return $parser; 874} 875 876sub _open_spool { 877 my $self = shift; 878 my $test = shift; 879 880 if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { 881 882 my $spool = File::Spec->catfile( $spool_dir, $test ); 883 884 # Make the directory 885 my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); 886 my $path = File::Spec->catpath( $vol, $dir, '' ); 887 eval { mkpath($path) }; 888 $self->_croak($@) if $@; 889 890 my $spool_handle = IO::Handle->new; 891 open( $spool_handle, ">$spool" ) 892 or $self->_croak(" Can't write $spool ( $! ) "); 893 894 return $spool_handle; 895 } 896 897 return; 898} 899 900sub _close_spool { 901 my $self = shift; 902 my ($parser) = @_; 903 904 if ( my $spool_handle = $parser->delete_spool ) { 905 close($spool_handle) 906 or $self->_croak(" Error closing TAP spool file( $! ) \n "); 907 } 908 909 return; 910} 911 912sub _croak { 913 my ( $self, $message ) = @_; 914 unless ($message) { 915 $message = $self->_error; 916 } 917 $self->SUPER::_croak($message); 918 919 return; 920} 921 9221; 923 924__END__ 925 926############################################################################## 927 928=head1 CONFIGURING 929 930C<TAP::Harness> is designed to be easy to configure. 931 932=head2 Plugins 933 934C<TAP::Parser> plugins let you change the way TAP is I<input> to and I<output> 935from the parser. 936 937L<TAP::Parser::SourceHandler>s handle TAP I<input>. You can configure them 938and load custom handlers using the C<sources> parameter to L</new>. 939 940L<TAP::Formatter>s handle TAP I<output>. You can load custom formatters by 941using the C<formatter_class> parameter to L</new>. To configure a formatter, 942you currently need to instantiate it outside of L<TAP::Harness> and pass it in 943with the C<formatter> parameter to L</new>. This I<may> be addressed by adding 944a I<formatters> parameter to L</new> in the future. 945 946=head2 C<Module::Build> 947 948L<Module::Build> version C<0.30> supports C<TAP::Harness>. 949 950To load C<TAP::Harness> plugins, you'll need to use the C<tap_harness_args> 951parameter to C<new>, typically from your C<Build.PL>. For example: 952 953 Module::Build->new( 954 module_name => 'MyApp', 955 test_file_exts => [qw(.t .tap .txt)], 956 use_tap_harness => 1, 957 tap_harness_args => { 958 sources => { 959 MyCustom => {}, 960 File => { 961 extensions => ['.tap', '.txt'], 962 }, 963 }, 964 formatter_class => 'TAP::Formatter::HTML', 965 }, 966 build_requires => { 967 'Module::Build' => '0.30', 968 'TAP::Harness' => '3.18', 969 }, 970 )->create_build_script; 971 972See L</new> 973 974=head2 C<ExtUtils::MakeMaker> 975 976L<ExtUtils::MakeMaker> does not support L<TAP::Harness> out-of-the-box. 977 978=head2 C<prove> 979 980L<prove> supports C<TAP::Harness> plugins, and has a plugin system of its 981own. See L<prove/FORMATTERS>, L<prove/SOURCE HANDLERS> and L<App::Prove> 982for more details. 983 984=head1 WRITING PLUGINS 985 986If you can't configure C<TAP::Harness> to do what you want, and you can't find 987an existing plugin, consider writing one. 988 989The two primary use cases supported by L<TAP::Harness> for plugins are I<input> 990and I<output>: 991 992=over 2 993 994=item Customize how TAP gets into the parser 995 996To do this, you can either extend an existing L<TAP::Parser::SourceHandler>, 997or write your own. It's a pretty simple API, and they can be loaded and 998configured using the C<sources> parameter to L</new>. 999 1000=item Customize how TAP results are output from the parser 1001 1002To do this, you can either extend an existing L<TAP::Formatter>, or write your 1003own. Writing formatters are a bit more involved than writing a 1004I<SourceHandler>, as you'll need to understand the L<TAP::Parser> API. A 1005good place to start is by understanding how L</aggregate_tests> works. 1006 1007Custom formatters can be loaded configured using the C<formatter_class> 1008parameter to L</new>. 1009 1010=back 1011 1012=head1 SUBCLASSING 1013 1014If you can't configure C<TAP::Harness> to do exactly what you want, and writing 1015a plugin isn't an option, consider extending it. It is designed to be (mostly) 1016easy to subclass, though the cases when sub-classing is necessary should be few 1017and far between. 1018 1019=head2 Methods 1020 1021The following methods are ones you may wish to override if you want to 1022subclass C<TAP::Harness>. 1023 1024=over 4 1025 1026=item L</new> 1027 1028=item L</runtests> 1029 1030=item L</summary> 1031 1032=back 1033 1034=cut 1035 1036=head1 REPLACING 1037 1038If you like the C<prove> utility and L<TAP::Parser> but you want your 1039own harness, all you need to do is write one and provide C<new> and 1040C<runtests> methods. Then you can use the C<prove> utility like so: 1041 1042 prove --harness My::Test::Harness 1043 1044Note that while C<prove> accepts a list of tests (or things to be 1045tested), C<new> has a fairly rich set of arguments. You'll probably want 1046to read over this code carefully to see how all of them are being used. 1047 1048=head1 SEE ALSO 1049 1050L<Test::Harness> 1051 1052=cut 1053 1054# vim:ts=4:sw=4:et:sta 1055