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.48 20 21=cut 22 23our $VERSION = '3.48'; 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 my $bailout; 559 eval { $self->aggregate_tests( $aggregate, @tests ); 1 } 560 or do { $bailout = $@ || 'unknown_error' }; 561 $finish->(); 562 die $bailout if defined $bailout; 563 }; 564 $self->{bail_summary} = sub{ 565 print "\n"; 566 $finish->(1); 567 }; 568 569 if ( $self->trap ) { 570 local $SIG{INT} = sub { 571 print "\n"; 572 $finish->(1); 573 exit; 574 }; 575 $run->(); 576 } 577 else { 578 $run->(); 579 } 580 581 return $aggregate; 582} 583 584=head3 C<summary> 585 586 $harness->summary( $aggregator ); 587 588Output the summary for a L<TAP::Parser::Aggregator>. 589 590=cut 591 592sub summary { 593 my ( $self, @args ) = @_; 594 $self->formatter->summary(@args); 595} 596 597sub _after_test { 598 my ( $self, $aggregate, $job, $parser ) = @_; 599 600 $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); 601 $aggregate->add( $job->description, $parser ); 602} 603 604sub _bailout { 605 my ( $self, $result, $parser, $session, $aggregate, $job ) = @_; 606 607 $self->finish_parser( $parser, $session ); 608 $self->_after_test( $aggregate, $job, $parser ); 609 $job->finish; 610 611 my $explanation = $result->explanation; 612 $self->{bail_summary}(); 613 die "FAILED--Further testing stopped" 614 . ( $explanation ? ": $explanation\n" : ".\n" ); 615} 616 617sub _aggregate_parallel { 618 my ( $self, $aggregate, $scheduler ) = @_; 619 620 my $jobs = $self->jobs; 621 my $mux = $self->_construct( $self->multiplexer_class ); 622 623 RESULT: { 624 625 # Keep multiplexer topped up 626 FILL: 627 while ( $mux->parsers < $jobs ) { 628 my $job = $scheduler->get_job; 629 630 # If we hit a spinner stop filling and start running. 631 last FILL if !defined $job || $job->is_spinner; 632 633 my ( $parser, $session ) = $self->make_parser($job); 634 $mux->add( $parser, [ $session, $job ] ); 635 636 # The job has started: begin the timers 637 $parser->start_time( $parser->get_time ); 638 $parser->start_times( $parser->get_times ); 639 } 640 641 if ( my ( $parser, $stash, $result ) = $mux->next ) { 642 my ( $session, $job ) = @$stash; 643 if ( defined $result ) { 644 $session->result($result); 645 $self->_bailout($result, $parser, $session, $aggregate, $job ) 646 if $result->is_bailout; 647 } 648 else { 649 650 # End of parser. Automatically removed from the mux. 651 $self->finish_parser( $parser, $session ); 652 $self->_after_test( $aggregate, $job, $parser ); 653 $job->finish; 654 } 655 redo RESULT; 656 } 657 } 658 659 return; 660} 661 662sub _aggregate_single { 663 my ( $self, $aggregate, $scheduler ) = @_; 664 665 JOB: 666 while ( my $job = $scheduler->get_job ) { 667 next JOB if $job->is_spinner; 668 669 my ( $parser, $session ) = $self->make_parser($job); 670 671 while ( defined( my $result = $parser->next ) ) { 672 $session->result($result); 673 if ( $result->is_bailout ) { 674 675 # Keep reading until input is exhausted in the hope 676 # of allowing any pending diagnostics to show up. 677 1 while $parser->next; 678 $self->_bailout($result, $parser, $session, $aggregate, $job ); 679 } 680 } 681 682 $self->finish_parser( $parser, $session ); 683 $self->_after_test( $aggregate, $job, $parser ); 684 $job->finish; 685 } 686 687 return; 688} 689 690=head3 C<aggregate_tests> 691 692 $harness->aggregate_tests( $aggregate, @tests ); 693 694Run the named tests and display a summary of result. Tests will be run 695in the order found. 696 697Test results will be added to the supplied L<TAP::Parser::Aggregator>. 698C<aggregate_tests> may be called multiple times to run several sets of 699tests. Multiple C<Test::Harness> instances may be used to pass results 700to a single aggregator so that different parts of a complex test suite 701may be run using different C<TAP::Harness> settings. This is useful, for 702example, in the case where some tests should run in parallel but others 703are unsuitable for parallel execution. 704 705 my $formatter = TAP::Formatter::Console->new; 706 my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); 707 my $par_harness = TAP::Harness->new( 708 { formatter => $formatter, 709 jobs => 9 710 } 711 ); 712 my $aggregator = TAP::Parser::Aggregator->new; 713 714 $aggregator->start(); 715 $ser_harness->aggregate_tests( $aggregator, @ser_tests ); 716 $par_harness->aggregate_tests( $aggregator, @par_tests ); 717 $aggregator->stop(); 718 $formatter->summary($aggregator); 719 720Note that for simpler testing requirements it will often be possible to 721replace the above code with a single call to C<runtests>. 722 723Each element of the C<@tests> array is either: 724 725=over 726 727=item * the source name of a test to run 728 729=item * a reference to a [ source name, display name ] array 730 731=back 732 733In the case of a perl test suite, typically I<source names> are simply the file 734names of the test scripts to run. 735 736When you supply a separate display name it becomes possible to run a 737test more than once; the display name is effectively the alias by which 738the test is known inside the harness. The harness doesn't care if it 739runs the same test more than once when each invocation uses a 740different name. 741 742=cut 743 744sub aggregate_tests { 745 my ( $self, $aggregate, @tests ) = @_; 746 747 my $jobs = $self->jobs; 748 my $scheduler = $self->make_scheduler(@tests); 749 750 # #12458 751 local $ENV{HARNESS_IS_VERBOSE} = 1 752 if $self->formatter->verbosity > 0; 753 754 # Formatter gets only names. 755 $self->formatter->prepare( map { $_->description } $scheduler->get_all ); 756 757 if ( $self->jobs > 1 ) { 758 $self->_aggregate_parallel( $aggregate, $scheduler ); 759 } 760 else { 761 $self->_aggregate_single( $aggregate, $scheduler ); 762 } 763 764 return; 765} 766 767sub _add_descriptions { 768 my $self = shift; 769 770 # Turn unwrapped scalars into anonymous arrays and copy the name as 771 # the description for tests that have only a name. 772 return map { @$_ == 1 ? [ $_->[0], $_->[0] ] : $_ } 773 map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_; 774} 775 776=head3 C<make_scheduler> 777 778Called by the harness when it needs to create a 779L<TAP::Parser::Scheduler>. Override in a subclass to provide an 780alternative scheduler. C<make_scheduler> is passed the list of tests 781that was passed to C<aggregate_tests>. 782 783=cut 784 785sub make_scheduler { 786 my ( $self, @tests ) = @_; 787 return $self->_construct( 788 $self->scheduler_class, 789 tests => [ $self->_add_descriptions(@tests) ], 790 rules => $self->rules 791 ); 792} 793 794=head3 C<jobs> 795 796Gets or sets the number of concurrent test runs the harness is 797handling. By default, this value is 1 -- for parallel testing, this 798should be set higher. 799 800=cut 801 802############################################################################## 803 804sub _get_parser_args { 805 my ( $self, $job ) = @_; 806 my $test_prog = $job->filename; 807 my %args = (); 808 809 $args{sources} = $self->sources if $self->sources; 810 811 my @switches; 812 @switches = $self->lib if $self->lib; 813 push @switches => $self->switches if $self->switches; 814 $args{switches} = \@switches; 815 $args{spool} = $self->_open_spool($test_prog); 816 $args{merge} = $self->merge; 817 $args{ignore_exit} = $self->ignore_exit; 818 $args{version} = $self->version if $self->version; 819 820 if ( my $exec = $self->exec ) { 821 $args{exec} 822 = ref $exec eq 'CODE' 823 ? $exec->( $self, $test_prog ) 824 : [ @$exec, $test_prog ]; 825 if ( not defined $args{exec} ) { 826 $args{source} = $test_prog; 827 } 828 elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) { 829 $args{source} = delete $args{exec}; 830 } 831 } 832 else { 833 $args{source} = $test_prog; 834 } 835 836 if ( defined( my $test_args = $self->test_args ) ) { 837 838 if ( ref($test_args) eq 'HASH' ) { 839 840 # different args for each test 841 if ( exists( $test_args->{ $job->description } ) ) { 842 $test_args = $test_args->{ $job->description }; 843 } 844 else { 845 $self->_croak( "TAP::Harness Can't find test_args for " 846 . $job->description ); 847 } 848 } 849 850 $args{test_args} = $test_args; 851 } 852 853 return \%args; 854} 855 856=head3 C<make_parser> 857 858Make a new parser and display formatter session. Typically used and/or 859overridden in subclasses. 860 861 my ( $parser, $session ) = $harness->make_parser; 862 863=cut 864 865sub make_parser { 866 my ( $self, $job ) = @_; 867 868 my $args = $self->_get_parser_args($job); 869 $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); 870 my $parser = $self->_construct( $self->parser_class, $args ); 871 872 $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); 873 my $session = $self->formatter->open_test( $job->description, $parser ); 874 875 return ( $parser, $session ); 876} 877 878=head3 C<finish_parser> 879 880Terminate use of a parser. Typically used and/or overridden in 881subclasses. The parser isn't destroyed as a result of this. 882 883=cut 884 885sub finish_parser { 886 my ( $self, $parser, $session ) = @_; 887 888 $session->close_test; 889 $self->_close_spool($parser); 890 891 return $parser; 892} 893 894sub _open_spool { 895 my $self = shift; 896 my $test = shift; 897 898 if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { 899 900 my $spool = File::Spec->catfile( $spool_dir, $test ); 901 902 # Make the directory 903 my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); 904 my $path = File::Spec->catpath( $vol, $dir, '' ); 905 eval { mkpath($path) }; 906 $self->_croak($@) if $@; 907 908 my $spool_handle = IO::Handle->new; 909 open( $spool_handle, ">$spool" ) 910 or $self->_croak(" Can't write $spool ( $! ) "); 911 912 return $spool_handle; 913 } 914 915 return; 916} 917 918sub _close_spool { 919 my $self = shift; 920 my ($parser) = @_; 921 922 if ( my $spool_handle = $parser->delete_spool ) { 923 close($spool_handle) 924 or $self->_croak(" Error closing TAP spool file( $! ) \n "); 925 } 926 927 return; 928} 929 930sub _croak { 931 my ( $self, $message ) = @_; 932 unless ($message) { 933 $message = $self->_error; 934 } 935 $self->SUPER::_croak($message); 936 937 return; 938} 939 9401; 941 942__END__ 943 944############################################################################## 945 946=head1 CONFIGURING 947 948C<TAP::Harness> is designed to be easy to configure. 949 950=head2 Plugins 951 952C<TAP::Parser> plugins let you change the way TAP is I<input> to and I<output> 953from the parser. 954 955L<TAP::Parser::SourceHandler>s handle TAP I<input>. You can configure them 956and load custom handlers using the C<sources> parameter to L</new>. 957 958L<TAP::Formatter>s handle TAP I<output>. You can load custom formatters by 959using the C<formatter_class> parameter to L</new>. To configure a formatter, 960you currently need to instantiate it outside of L<TAP::Harness> and pass it in 961with the C<formatter> parameter to L</new>. This I<may> be addressed by adding 962a I<formatters> parameter to L</new> in the future. 963 964=head2 C<Module::Build> 965 966L<Module::Build> version C<0.30> supports C<TAP::Harness>. 967 968To load C<TAP::Harness> plugins, you'll need to use the C<tap_harness_args> 969parameter to C<new>, typically from your C<Build.PL>. For example: 970 971 Module::Build->new( 972 module_name => 'MyApp', 973 test_file_exts => [qw(.t .tap .txt)], 974 use_tap_harness => 1, 975 tap_harness_args => { 976 sources => { 977 MyCustom => {}, 978 File => { 979 extensions => ['.tap', '.txt'], 980 }, 981 }, 982 formatter_class => 'TAP::Formatter::HTML', 983 }, 984 build_requires => { 985 'Module::Build' => '0.30', 986 'TAP::Harness' => '3.18', 987 }, 988 )->create_build_script; 989 990See L</new> 991 992=head2 C<ExtUtils::MakeMaker> 993 994L<ExtUtils::MakeMaker> does not support L<TAP::Harness> out-of-the-box. 995 996=head2 C<prove> 997 998L<prove> supports C<TAP::Harness> plugins, and has a plugin system of its 999own. See L<prove/FORMATTERS>, L<prove/SOURCE HANDLERS> and L<App::Prove> 1000for more details. 1001 1002=head1 WRITING PLUGINS 1003 1004If you can't configure C<TAP::Harness> to do what you want, and you can't find 1005an existing plugin, consider writing one. 1006 1007The two primary use cases supported by L<TAP::Harness> for plugins are I<input> 1008and I<output>: 1009 1010=over 2 1011 1012=item Customize how TAP gets into the parser 1013 1014To do this, you can either extend an existing L<TAP::Parser::SourceHandler>, 1015or write your own. It's a pretty simple API, and they can be loaded and 1016configured using the C<sources> parameter to L</new>. 1017 1018=item Customize how TAP results are output from the parser 1019 1020To do this, you can either extend an existing L<TAP::Formatter>, or write your 1021own. Writing formatters are a bit more involved than writing a 1022I<SourceHandler>, as you'll need to understand the L<TAP::Parser> API. A 1023good place to start is by understanding how L</aggregate_tests> works. 1024 1025Custom formatters can be loaded configured using the C<formatter_class> 1026parameter to L</new>. 1027 1028=back 1029 1030=head1 SUBCLASSING 1031 1032If you can't configure C<TAP::Harness> to do exactly what you want, and writing 1033a plugin isn't an option, consider extending it. It is designed to be (mostly) 1034easy to subclass, though the cases when sub-classing is necessary should be few 1035and far between. 1036 1037=head2 Methods 1038 1039The following methods are ones you may wish to override if you want to 1040subclass C<TAP::Harness>. 1041 1042=over 4 1043 1044=item L</new> 1045 1046=item L</runtests> 1047 1048=item L</summary> 1049 1050=back 1051 1052=cut 1053 1054=head1 REPLACING 1055 1056If you like the C<prove> utility and L<TAP::Parser> but you want your 1057own harness, all you need to do is write one and provide C<new> and 1058C<runtests> methods. Then you can use the C<prove> utility like so: 1059 1060 prove --harness My::Test::Harness 1061 1062Note that while C<prove> accepts a list of tests (or things to be 1063tested), C<new> has a fairly rich set of arguments. You'll probably want 1064to read over this code carefully to see how all of them are being used. 1065 1066=head1 SEE ALSO 1067 1068L<Test::Harness> 1069 1070=cut 1071 1072# vim:ts=4:sw=4:et:sta 1073