ext/Test/Harness/lib/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.14
  23
  24 =cut
  25
  26 $VERSION = '3.14';
  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 errors stdout color show_count
  64     );
  65
  66     %VALIDATION_FOR = (
  67         lib => sub {
  68             my ( $self, $libs ) = @_;
  69             $libs = [$libs] unless 'ARRAY' eq ref $libs;
  70
  71             return [ map {"-I$_"} @$libs ];
  72         },
  73         switches          => sub { shift; shift },
  74         exec              => sub { shift; shift },
  75         merge             => sub { shift; shift },
  76         aggregator_class  => sub { shift; shift },
  77         formatter_class   => sub { shift; shift },
  78         multiplexer_class => sub { shift; shift },
  79         parser_class      => sub { shift; shift },
  80         scheduler_class   => sub { shift; shift },
  81         formatter         => sub { shift; shift },
  82         jobs              => sub { shift; shift },
  83         fork              => sub { shift; shift },
  84         test_args         => sub { shift; shift },
  85         ignore_exit       => sub { shift; shift },
  86         rules             => sub { shift; shift },
  87     );
  88
  89     for my $method ( sort keys %VALIDATION_FOR ) {
  90         no strict 'refs';
  91         if ( $method eq 'lib' || $method eq 'switches' ) {
  92             *{$method} = sub {
  93                 my $self = shift;
  94                 unless (@_) {
  95                     $self->{$method} ||= [];
  96                     return wantarray
  97                       ? @{ $self->{$method} }
  98                       : $self->{$method};
  99                 }
 100                 $self->_croak("Too many arguments to method '$method'")
 101                   if @_ > 1;
 102                 my $args = shift;
 103                 $args = [$args] unless ref $args;
 104                 $self->{$method} = $args;
 105                 return $self;
 106             };
 107         }
 108         else {
 109             *{$method} = sub {
 110                 my $self = shift;
 111                 return $self->{$method} unless @_;
 112                 $self->{$method} = shift;
 113             };
 114         }
 115     }
 116
 117     for my $method (@FORMATTER_ARGS) {
 118         no strict 'refs';
 119         *{$method} = sub {
 120             my $self = shift;
 121             return $self->formatter->$method(@_);
 122         };
 123     }
 124 }
 125
 126 ##############################################################################
 127
 128 =head1 METHODS
 129
 130 =head2 Class Methods
 131
 132 =head3 C<new>
 133
 134  my %args = (
 135     verbosity => 1,
 136     lib     => [ 'lib', 'blib/lib' ],
 137  )
 138  my $harness = TAP::Harness->new( \%args );
 139
 140 The constructor returns a new C<TAP::Harness> object. It accepts an
 141 optional hashref whose allowed keys are:
 142
 143 =over 4
 144
 145 =item * C<verbosity>
 146
 147 Set the verbosity level:
 148
 149      1   verbose        Print individual test results to STDOUT.
 150      0   normal
 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.
 155
 156 =item * C<timer>
 157
 158 Append run time for each test to output. Uses L<Time::HiRes> if
 159 available.
 160
 161 =item * C<failures>
 162
 163 Only show test failures (this is a no-op if C<verbose> is selected).
 164
 165 =item * C<show_count>
 166
 167 Update the running test count during testing.
 168
 169 =item * C<lib>
 170
 171 Accepts a scalar value or array ref of scalar values indicating which
 172 paths to allowed libraries should be included if Perl tests are
 173 executed. Naturally, this only makes sense in the context of tests
 174 written in Perl.
 175
 176 =item * C<switches>
 177
 178 Accepts a scalar value or array ref of scalar values indicating which
 179 switches should be included if Perl tests are executed. Naturally, this
 180 only makes sense in the context of tests written in Perl.
 181
 182 =item * C<test_args>
 183
 184 A reference to an C<@INC> style array of arguments to be passed to each
 185 test program.
 186
 187 =item * C<color>
 188
 189 Attempt to produce color output.
 190
 191 =item * C<exec>
 192
 193 Typically, Perl tests are run through this. However, anything which
 194 spits out TAP is fine. You can use this argument to specify the name of
 195 the program (and optional switches) to run your tests with:
 196
 197   exec => ['/usr/bin/ruby', '-w']
 198
 199 You can also pass a subroutine reference in order to determine and
 200 return the proper program to run based on a given test script. The
 201 subroutine reference should expect the TAP::Harness object itself as the
 202 first argument, and the file name as the second argument. It should
 203 return an array reference containing the command to be run and including
 204 the test file name. It can also simply return C<undef>, in which case
 205 TAP::Harness will fall back on executing the test script in Perl:
 206
 207     exec => sub {
 208         my ( $harness, $test_file ) = @_;
 209
 210         # Let Perl tests run.
 211         return undef if $test_file =~ /[.]t$/;
 212         return [ qw( /usr/bin/ruby -w ), $test_file ]
 213           if $test_file =~ /[.]rb$/;
 214       }
 215
 216 =item * C<merge>
 217
 218 If C<merge> is true the harness will create parsers that merge STDOUT
 219 and STDERR together for any processes they start.
 220
 221 =item * C<aggregator_class>
 222
 223 The name of the class to use to aggregate test results. The default is
 224 L<TAP::Parser::Aggregator>.
 225
 226 =item * C<formatter_class>
 227
 228 The name of the class to use to format output. The default is
 229 L<TAP::Formatter::Console>.
 230
 231 =item * C<multiplexer_class>
 232
 233 The name of the class to use to multiplex tests during parallel testing.
 234 The default is L<TAP::Parser::Multiplexer>.
 235
 236 =item * C<parser_class>
 237
 238 The name of the class to use to parse TAP. The default is
 239 L<TAP::Parser>.
 240
 241 =item * C<scheduler_class>
 242
 243 The name of the class to use to schedule test execution. The default is
 244 L<TAP::Parser::Scheduler>.
 245
 246 =item * C<formatter>
 247
 248 If set C<formatter> must be an object that is capable of formatting the
 249 TAP output. See L<TAP::Formatter::Console> for an example.
 250
 251 =item * C<errors>
 252
 253 If parse errors are found in the TAP output, a note of this will be
 254 made in the summary report. To see all of the parse errors, set this
 255 argument to true:
 256
 257   errors => 1
 258
 259 =item * C<directives>
 260
 261 If set to a true value, only test results with directives will be
 262 displayed. This overrides other settings such as C<verbose> or
 263 C<failures>.
 264
 265 =item * C<ignore_exit>
 266
 267 If set to a true value instruct C<TAP::Parser> to ignore exit and wait
 268 status from test scripts.
 269
 270 =item * C<jobs>
 271
 272 The maximum number of parallel tests to run at any time.  Which tests
 273 can be run in parallel is controlled by C<rules>.  The default is to
 274 run only one test at a time.
 275
 276 =item * C<fork>
 277
 278 If true the harness will attempt to fork and run the parser for each
 279 test in a separate process. Currently this option requires
 280 L<Parallel::Iterator> to be installed.
 281
 282 =item * C<rules>
 283
 284 A reference to a hash of rules that control which tests may be
 285 executed in parallel. This is an experimental feature and the
 286 interface may change.
 287
 288     $harness->rules(
 289         {   par => [
 290                 { seq => '../ext/DB_File/t/*' },
 291                 { seq => '../ext/IO_Compress_Zlib/t/*' },
 292                 { seq => '../lib/CPANPLUS/*' },
 293                 { seq => '../lib/ExtUtils/t/*' },
 294                 '*'
 295             ]
 296         }
 297     );
 298
 299 =item * C<stdout>
 300
 301 A filehandle for catching standard output.
 302
 303 =back
 304
 305 Any keys for which the value is C<undef> will be ignored.
 306
 307 =cut
 308
 309 # new supplied by TAP::Base
 310
 311 {
 312     my @legal_callback = qw(
 313       parser_args
 314       made_parser
 315       before_runtests
 316       after_runtests
 317       after_test
 318     );
 319
 320     my %default_class = (
 321         aggregator_class  => 'TAP::Parser::Aggregator',
 322         formatter_class   => 'TAP::Formatter::Console',
 323         multiplexer_class => 'TAP::Parser::Multiplexer',
 324         parser_class      => 'TAP::Parser',
 325         scheduler_class   => 'TAP::Parser::Scheduler',
 326     );
 327
 328     sub _initialize {
 329         my ( $self, $arg_for ) = @_;
 330         $arg_for ||= {};
 331
 332         $self->SUPER::_initialize( $arg_for, \@legal_callback );
 333         my %arg_for = %$arg_for;    # force a shallow copy
 334
 335         for my $name ( sort keys %VALIDATION_FOR ) {
 336             my $property = delete $arg_for{$name};
 337             if ( defined $property ) {
 338                 my $validate = $VALIDATION_FOR{$name};
 339
 340                 my $value = $self->$validate($property);
 341                 if ( $self->_error ) {
 342                     $self->_croak;
 343                 }
 344                 $self->$name($value);
 345             }
 346         }
 347
 348         $self->jobs(1) unless defined $self->jobs;
 349
 350         while ( my ( $attr, $class ) = each %default_class ) {
 351             $self->$attr( $self->$attr() || $class );
 352         }
 353
 354         unless ( $self->formatter ) {
 355
 356             # This is a little bodge to preserve legacy behaviour. It's
 357             # pretty horrible that we know which args are destined for
 358             # the formatter.
 359             my %formatter_args = ( jobs => $self->jobs );
 360             for my $name (@FORMATTER_ARGS) {
 361                 if ( defined( my $property = delete $arg_for{$name} ) ) {
 362                     $formatter_args{$name} = $property;
 363                 }
 364             }
 365
 366             $self->formatter(
 367                 $self->_construct( $self->formatter_class, \%formatter_args )
 368             );
 369         }
 370
 371         if ( my @props = sort keys %arg_for ) {
 372             $self->_croak("Unknown arguments to TAP::Harness::new (@props)");
 373         }
 374
 375         return $self;
 376     }
 377 }
 378
 379 ##############################################################################
 380
 381 =head2 Instance Methods
 382
 383 =head3 C<runtests>
 384
 385     $harness->runtests(@tests);
 386
 387 Accepts and array of C<@tests> to be run. This should generally be the
 388 names of test files, but this is not required. Each element in C<@tests>
 389 will be passed to C<TAP::Parser::new()> as a C<source>. See
 390 L<TAP::Parser> for more information.
 391
 392 It is possible to provide aliases that will be displayed in place of the
 393 test name by supplying the test as a reference to an array containing
 394 C<< [ $test, $alias ] >>:
 395
 396     $harness->runtests( [ 't/foo.t', 'Foo Once' ],
 397                         [ 't/foo.t', 'Foo Twice' ] );
 398
 399 Normally it is an error to attempt to run the same test twice. Aliases
 400 allow you to overcome this limitation by giving each run of the test a
 401 unique name.
 402
 403 Tests will be run in the order found.
 404
 405 If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it
 406 should name a directory into which a copy of the raw TAP for each test
 407 will be written. TAP is written to files named for each test.
 408 Subdirectories will be created as needed.
 409
 410 Returns a L<TAP::Parser::Aggregator> containing the test results.
 411
 412 =cut
 413
 414 sub runtests {
 415     my ( $self, @tests ) = @_;
 416
 417     my $aggregate = $self->_construct( $self->aggregator_class );
 418
 419     $self->_make_callback( 'before_runtests', $aggregate );
 420     $aggregate->start;
 421     $self->aggregate_tests( $aggregate, @tests );
 422     $aggregate->stop;
 423     $self->summary($aggregate);
 424     $self->_make_callback( 'after_runtests', $aggregate );
 425
 426     return $aggregate;
 427 }
 428
 429 =head3 C<summary>
 430
 431 Output the summary for a TAP::Parser::Aggregator.
 432
 433 =cut
 434
 435 sub summary {
 436     my ( $self, $aggregate ) = @_;
 437     $self->formatter->summary($aggregate);
 438 }
 439
 440 sub _after_test {
 441     my ( $self, $aggregate, $job, $parser ) = @_;
 442
 443     $self->_make_callback( 'after_test', $job->as_array_ref, $parser );
 444     $aggregate->add( $job->description, $parser );
 445 }
 446
 447 sub _aggregate_forked {
 448     my ( $self, $aggregate, $scheduler ) = @_;
 449
 450     eval { require Parallel::Iterator };
 451
 452     croak "Parallel::Iterator required for --fork option ($@)"
 453       if $@;
 454
 455     my $iter = Parallel::Iterator::iterate(
 456         { workers => $self->jobs || 0 },
 457         sub {
 458             my $job = shift;
 459
 460             return if $job->is_spinner;
 461
 462             my ( $parser, $session ) = $self->make_parser($job);
 463
 464             while ( defined( my $result = $parser->next ) ) {
 465                 exit 1 if $result->is_bailout;
 466             }
 467
 468             $self->finish_parser( $parser, $session );
 469
 470             # Can't serialise coderefs...
 471             delete $parser->{_iter};
 472             delete $parser->{_stream};
 473             delete $parser->{_grammar};
 474             return $parser;
 475         },
 476         sub { $scheduler->get_job }
 477     );
 478
 479     while ( my ( $job, $parser ) = $iter->() ) {
 480         next if $job->is_spinner;
 481         $self->_after_test( $aggregate, $job, $parser );
 482         $job->finish;
 483     }
 484
 485     return;
 486 }
 487
 488 sub _aggregate_parallel {
 489     my ( $self, $aggregate, $scheduler ) = @_;
 490
 491     my $jobs = $self->jobs;
 492     my $mux  = $self->_construct( $self->multiplexer_class );
 493
 494     RESULT: {
 495
 496         # Keep multiplexer topped up
 497         FILL:
 498         while ( $mux->parsers < $jobs ) {
 499             my $job = $scheduler->get_job;
 500
 501             # If we hit a spinner stop filling and start running.
 502             last FILL if !defined $job || $job->is_spinner;
 503
 504             my ( $parser, $session ) = $self->make_parser($job);
 505             $mux->add( $parser, [ $session, $job ] );
 506         }
 507
 508         if ( my ( $parser, $stash, $result ) = $mux->next ) {
 509             my ( $session, $job ) = @$stash;
 510             if ( defined $result ) {
 511                 $session->result($result);
 512                 exit 1 if $result->is_bailout;
 513             }
 514             else {
 515
 516                 # End of parser. Automatically removed from the mux.
 517                 $self->finish_parser( $parser, $session );
 518                 $self->_after_test( $aggregate, $job, $parser );
 519                 $job->finish;
 520             }
 521             redo RESULT;
 522         }
 523     }
 524
 525     return;
 526 }
 527
 528 sub _aggregate_single {
 529     my ( $self, $aggregate, $scheduler ) = @_;
 530
 531     JOB:
 532     while ( my $job = $scheduler->get_job ) {
 533         next JOB if $job->is_spinner;
 534
 535         my ( $parser, $session ) = $self->make_parser($job);
 536
 537         while ( defined( my $result = $parser->next ) ) {
 538             $session->result($result);
 539             if ( $result->is_bailout ) {
 540
 541                 # Keep reading until input is exhausted in the hope
 542                 # of allowing any pending diagnostics to show up.
 543                 1 while $parser->next;
 544                 exit 1;
 545             }
 546         }
 547
 548         $self->finish_parser( $parser, $session );
 549         $self->_after_test( $aggregate, $job, $parser );
 550         $job->finish;
 551     }
 552
 553     return;
 554 }
 555
 556 =head3 C<aggregate_tests>
 557
 558   $harness->aggregate_tests( $aggregate, @tests );
 559
 560 Run the named tests and display a summary of result. Tests will be run
 561 in the order found.
 562
 563 Test results will be added to the supplied L<TAP::Parser::Aggregator>.
 564 C<aggregate_tests> may be called multiple times to run several sets of
 565 tests. Multiple C<Test::Harness> instances may be used to pass results
 566 to a single aggregator so that different parts of a complex test suite
 567 may be run using different C<TAP::Harness> settings. This is useful, for
 568 example, in the case where some tests should run in parallel but others
 569 are unsuitable for parallel execution.
 570
 571     my $formatter   = TAP::Formatter::Console->new;
 572     my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
 573     my $par_harness = TAP::Harness->new(
 574         {   formatter => $formatter,
 575             jobs      => 9
 576         }
 577     );
 578     my $aggregator = TAP::Parser::Aggregator->new;
 579
 580     $aggregator->start();
 581     $ser_harness->aggregate_tests( $aggregator, @ser_tests );
 582     $par_harness->aggregate_tests( $aggregator, @par_tests );
 583     $aggregator->stop();
 584     $formatter->summary($aggregator);
 585
 586 Note that for simpler testing requirements it will often be possible to
 587 replace the above code with a single call to C<runtests>.
 588
 589 Each elements of the @tests array is either
 590
 591 =over
 592
 593 =item * the file name of a test script to run
 594
 595 =item * a reference to a [ file name, display name ] array
 596
 597 =back
 598
 599 When you supply a separate display name it becomes possible to run a
 600 test more than once; the display name is effectively the alias by which
 601 the test is known inside the harness. The harness doesn't care if it
 602 runs the same script more than once when each invocation uses a
 603 different name.
 604
 605 =cut
 606
 607 sub aggregate_tests {
 608     my ( $self, $aggregate, @tests ) = @_;
 609
 610     my $jobs      = $self->jobs;
 611     my $scheduler = $self->make_scheduler(@tests);
 612
 613     # #12458
 614     local $ENV{HARNESS_IS_VERBOSE} = 1
 615       if $self->formatter->verbosity > 0;
 616
 617     # Formatter gets only names.
 618     $self->formatter->prepare( map { $_->description } $scheduler->get_all );
 619
 620     if ( $self->jobs > 1 ) {
 621         if ( $self->fork ) {
 622             $self->_aggregate_forked( $aggregate, $scheduler );
 623         }
 624         else {
 625             $self->_aggregate_parallel( $aggregate, $scheduler );
 626         }
 627     }
 628     else {
 629         $self->_aggregate_single( $aggregate, $scheduler );
 630     }
 631
 632     return;
 633 }
 634
 635 sub _add_descriptions {
 636     my $self = shift;
 637
 638     # First transformation: turn scalars into single element arrays
 639     my @tests = map { 'ARRAY' eq ref $_ ? $_ : [$_] } @_;
 640
 641     # Work out how many different extensions we have
 642     my %ext;
 643     for my $test (@tests) {
 644         $ext{$1}++ if $test->[0] =~ /\.(\w+)$/;
 645     }
 646
 647     for my $test (@tests) {
 648         if ( @$test == 1 ) {
 649             $test->[1] = $test->[0];
 650             $test->[1] =~ s/\.\w+$//
 651               if keys %ext <= 1;
 652         }
 653     }
 654     return @tests;
 655 }
 656
 657 =head3 C<make_scheduler>
 658
 659 Called by the harness when it needs to create a
 660 L<TAP::Parser::Scheduler>. Override in a subclass to provide an
 661 alternative scheduler. C<make_scheduler> is passed the list of tests
 662 that was passed to C<aggregate_tests>.
 663
 664 =cut
 665
 666 sub make_scheduler {
 667     my ( $self, @tests ) = @_;
 668     return $self->_construct(
 669         $self->scheduler_class,
 670         tests => [ $self->_add_descriptions(@tests) ],
 671         rules => $self->rules
 672     );
 673 }
 674
 675 =head3 C<jobs>
 676
 677 Gets or sets the number of concurrent test runs the harness is handling.
 678 For the default harness this value is always 1. A parallel harness such
 679 as L<TAP::Harness::Parallel> will override this to return the number of
 680 jobs it is handling.
 681
 682 =head3 C<fork>
 683
 684 If true the harness will attempt to fork and run the parser for each
 685 test in a separate process. Currently this option requires
 686 L<Parallel::Iterator> to be installed.
 687
 688 =cut
 689
 690 ##############################################################################
 691
 692 =head1 SUBCLASSING
 693
 694 C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
 695 don't like how a particular feature functions, just override the
 696 desired methods.
 697
 698 =head2 Methods
 699
 700 TODO: This is out of date
 701
 702 The following methods are ones you may wish to override if you want to
 703 subclass C<TAP::Harness>.
 704
 705 =head3 C<summary>
 706
 707   $harness->summary( \%args );
 708
 709 C<summary> prints the summary report after all tests are run. The
 710 argument is a hashref with the following keys:
 711
 712 =over 4
 713
 714 =item * C<start>
 715
 716 This is created with C<< Benchmark->new >> and it the time the tests
 717 started. You can print a useful summary time, if desired, with:
 718
 719     $self->output(
 720         timestr( timediff( Benchmark->new, $start_time ), 'nop' ) );
 721
 722 =item * C<tests>
 723
 724 This is an array reference of all test names. To get the L<TAP::Parser>
 725 object for individual tests:
 726
 727  my $aggregate = $args->{aggregate};
 728  my $tests     = $args->{tests};
 729
 730  for my $name ( @$tests ) {
 731      my ($parser) = $aggregate->parsers($test);
 732      ... do something with $parser
 733  }
 734
 735 This is a bit clunky and will be cleaned up in a later release.
 736
 737 =back
 738
 739 =cut
 740
 741 sub _get_parser_args {
 742     my ( $self, $job ) = @_;
 743     my $test_prog = $job->filename;
 744     my %args      = ();
 745     my @switches;
 746     @switches = $self->lib if $self->lib;
 747     push @switches => $self->switches if $self->switches;
 748     $args{switches}    = \@switches;
 749     $args{spool}       = $self->_open_spool($test_prog);
 750     $args{merge}       = $self->merge;
 751     $args{ignore_exit} = $self->ignore_exit;
 752
 753     if ( my $exec = $self->exec ) {
 754         $args{exec}
 755           = ref $exec eq 'CODE'
 756           ? $exec->( $self, $test_prog )
 757           : [ @$exec, $test_prog ];
 758         $args{source} = $test_prog unless $args{exec};
 759     }
 760     else {
 761         $args{source} = $test_prog;
 762     }
 763
 764     if ( defined( my $test_args = $self->test_args ) ) {
 765         $args{test_args} = $test_args;
 766     }
 767
 768     return \%args;
 769 }
 770
 771 =head3 C<make_parser>
 772
 773 Make a new parser and display formatter session. Typically used and/or
 774 overridden in subclasses.
 775
 776     my ( $parser, $session ) = $harness->make_parser;
 777
 778 =cut
 779
 780 sub make_parser {
 781     my ( $self, $job ) = @_;
 782
 783     my $args = $self->_get_parser_args($job);
 784     $self->_make_callback( 'parser_args', $args, $job->as_array_ref );
 785     my $parser = $self->_construct( $self->parser_class, $args );
 786
 787     $self->_make_callback( 'made_parser', $parser, $job->as_array_ref );
 788     my $session = $self->formatter->open_test( $job->description, $parser );
 789
 790     return ( $parser, $session );
 791 }
 792
 793 =head3 C<finish_parser>
 794
 795 Terminate use of a parser. Typically used and/or overridden in
 796 subclasses. The parser isn't destroyed as a result of this.
 797
 798 =cut
 799
 800 sub finish_parser {
 801     my ( $self, $parser, $session ) = @_;
 802
 803     $session->close_test;
 804     $self->_close_spool($parser);
 805
 806     return $parser;
 807 }
 808
 809 sub _open_spool {
 810     my $self = shift;
 811     my $test = shift;
 812
 813     if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {
 814
 815         my $spool = File::Spec->catfile( $spool_dir, $test );
 816
 817         # Make the directory
 818         my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
 819         my $path = File::Spec->catpath( $vol, $dir, '' );
 820         eval { mkpath($path) };
 821         $self->_croak($@) if $@;
 822
 823         my $spool_handle = IO::Handle->new;
 824         open( $spool_handle, ">$spool" )
 825           or $self->_croak(" Can't write $spool ( $! ) ");
 826
 827         return $spool_handle;
 828     }
 829
 830     return;
 831 }
 832
 833 sub _close_spool {
 834     my $self = shift;
 835     my ($parser) = @_;
 836
 837     if ( my $spool_handle = $parser->delete_spool ) {
 838         close($spool_handle)
 839           or $self->_croak(" Error closing TAP spool file( $! ) \n ");
 840     }
 841
 842     return;
 843 }
 844
 845 sub _croak {
 846     my ( $self, $message ) = @_;
 847     unless ($message) {
 848         $message = $self->_error;
 849     }
 850     $self->SUPER::_croak($message);
 851
 852     return;
 853 }
 854
 855 =head1 REPLACING
 856
 857 If you like the C<prove> utility and L<TAP::Parser> but you want your
 858 own harness, all you need to do is write one and provide C<new> and
 859 C<runtests> methods. Then you can use the C<prove> utility like so:
 860
 861  prove --harness My::Test::Harness
 862
 863 Note that while C<prove> accepts a list of tests (or things to be
 864 tested), C<new> has a fairly rich set of arguments. You'll probably want
 865 to read over this code carefully to see how all of them are being used.
 866
 867 =head1 SEE ALSO
 868
 869 L<Test::Harness>
 870
 871 =cut
 872
 873 1;
 874
 875 # vim:ts=4:sw=4:et:sta