lib/perl5/5.8.8/TAP/Harness.pm

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