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