Commit | Line | Data |
---|---|---|
b965d173 NC |
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 | use TAP::Parser; | |
12 | use TAP::Parser::Aggregator; | |
13 | use TAP::Parser::Multiplexer; | |
14 | ||
15 | use vars qw($VERSION @ISA); | |
16 | ||
17 | @ISA = qw(TAP::Base); | |
18 | ||
19 | =head1 NAME | |
20 | ||
21 | TAP::Harness - Run test scripts with statistics | |
22 | ||
23 | =head1 VERSION | |
24 | ||
2a7f4b9b | 25 | Version 3.10 |
b965d173 NC |
26 | |
27 | =cut | |
28 | ||
2a7f4b9b | 29 | $VERSION = '3.10'; |
b965d173 NC |
30 | |
31 | $ENV{HARNESS_ACTIVE} = 1; | |
32 | $ENV{HARNESS_VERSION} = $VERSION; | |
33 | ||
34 | END { | |
35 | ||
36 | # For VMS. | |
37 | delete $ENV{HARNESS_ACTIVE}; | |
38 | delete $ENV{HARNESS_VERSION}; | |
39 | } | |
40 | ||
41 | =head1 DESCRIPTION | |
42 | ||
43 | This is a simple test harness which allows tests to be run and results | |
44 | automatically aggregated and output to STDOUT. | |
45 | ||
46 | =head1 SYNOPSIS | |
47 | ||
48 | use TAP::Harness; | |
49 | my $harness = TAP::Harness->new( \%args ); | |
50 | $harness->runtests(@tests); | |
51 | ||
52 | =cut | |
53 | ||
54 | my %VALIDATION_FOR; | |
55 | my @FORMATTER_ARGS; | |
56 | ||
57 | sub _error { | |
58 | my $self = shift; | |
59 | return $self->{error} unless @_; | |
60 | $self->{error} = shift; | |
61 | } | |
62 | ||
63 | BEGIN { | |
64 | ||
65 | @FORMATTER_ARGS = qw( | |
66 | directives verbosity timer failures errors stdout color | |
67 | ); | |
68 | ||
69 | %VALIDATION_FOR = ( | |
70 | lib => sub { | |
71 | my ( $self, $libs ) = @_; | |
72 | $libs = [$libs] unless 'ARRAY' eq ref $libs; | |
73 | ||
74 | return [ map {"-I$_"} @$libs ]; | |
75 | }, | |
76 | switches => sub { shift; shift }, | |
77 | exec => sub { shift; shift }, | |
78 | merge => sub { shift; shift }, | |
79 | formatter_class => sub { shift; shift }, | |
80 | formatter => sub { shift; shift }, | |
81 | jobs => sub { shift; shift }, | |
82 | fork => sub { shift; shift }, | |
83 | test_args => sub { shift; shift }, | |
84 | ); | |
85 | ||
86 | for my $method ( sort keys %VALIDATION_FOR ) { | |
87 | no strict 'refs'; | |
88 | if ( $method eq 'lib' || $method eq 'switches' ) { | |
89 | *{$method} = sub { | |
90 | my $self = shift; | |
91 | unless (@_) { | |
92 | $self->{$method} ||= []; | |
93 | return wantarray | |
94 | ? @{ $self->{$method} } | |
95 | : $self->{$method}; | |
96 | } | |
97 | $self->_croak("Too many arguments to method '$method'") | |
98 | if @_ > 1; | |
99 | my $args = shift; | |
100 | $args = [$args] unless ref $args; | |
101 | $self->{$method} = $args; | |
102 | return $self; | |
103 | }; | |
104 | } | |
105 | else { | |
106 | *{$method} = sub { | |
107 | my $self = shift; | |
108 | return $self->{$method} unless @_; | |
109 | $self->{$method} = shift; | |
110 | }; | |
111 | } | |
112 | } | |
113 | ||
114 | for my $method (@FORMATTER_ARGS) { | |
115 | no strict 'refs'; | |
116 | *{$method} = sub { | |
117 | my $self = shift; | |
118 | return $self->formatter->$method(@_); | |
119 | }; | |
120 | } | |
121 | } | |
122 | ||
123 | ############################################################################## | |
124 | ||
125 | =head1 METHODS | |
126 | ||
127 | =head2 Class Methods | |
128 | ||
129 | =head3 C<new> | |
130 | ||
131 | my %args = ( | |
132 | verbosity => 1, | |
133 | lib => [ 'lib', 'blib/lib' ], | |
134 | ) | |
135 | my $harness = TAP::Harness->new( \%args ); | |
136 | ||
137 | The constructor returns a new C<TAP::Harness> object. It accepts an optional | |
138 | hashref whose allowed keys are: | |
139 | ||
140 | =over 4 | |
141 | ||
142 | =item * C<verbosity> | |
143 | ||
144 | Set the verbosity level: | |
145 | ||
146 | 1 verbose Print individual test results to STDOUT. | |
147 | 0 normal | |
148 | -1 quiet Suppress some test output (mostly failures | |
149 | while tests are running). | |
150 | -2 really quiet Suppress everything but the tests summary. | |
151 | ||
152 | =item * C<timer> | |
153 | ||
154 | Append run time for each test to output. Uses L<Time::HiRes> if available. | |
155 | ||
156 | =item * C<failures> | |
157 | ||
158 | Only show test failures (this is a no-op if C<verbose> is selected). | |
159 | ||
160 | =item * C<lib> | |
161 | ||
162 | Accepts a scalar value or array ref of scalar values indicating which paths to | |
163 | allowed libraries should be included if Perl tests are executed. Naturally, | |
164 | this only makes sense in the context of tests written in Perl. | |
165 | ||
166 | =item * C<switches> | |
167 | ||
168 | Accepts a scalar value or array ref of scalar values indicating which switches | |
169 | should be included if Perl tests are executed. Naturally, this only makes | |
170 | sense in the context of tests written in Perl. | |
171 | ||
172 | =item * C<test_args> | |
173 | ||
174 | A reference to an C<@INC> style array of arguments to be passed to each | |
175 | test program. | |
176 | ||
177 | =item * C<color> | |
178 | ||
179 | Attempt to produce color output. | |
180 | ||
181 | =item * C<exec> | |
182 | ||
183 | Typically, Perl tests are run through this. However, anything which spits out | |
184 | TAP is fine. You can use this argument to specify the name of the program | |
185 | (and optional switches) to run your tests with: | |
186 | ||
187 | exec => ['/usr/bin/ruby', '-w'] | |
188 | ||
189 | =item * C<merge> | |
190 | ||
191 | If C<merge> is true the harness will create parsers that merge STDOUT | |
192 | and STDERR together for any processes they start. | |
193 | ||
194 | =item * C<formatter_class> | |
195 | ||
196 | The name of the class to use to format output. The default is | |
197 | L<TAP::Formatter::Console>. | |
198 | ||
199 | =item * C<formatter> | |
200 | ||
201 | If set C<formatter> must be an object that is capable of formatting the | |
202 | TAP output. See L<TAP::Formatter::Console> for an example. | |
203 | ||
204 | =item * C<errors> | |
205 | ||
206 | If parse errors are found in the TAP output, a note of this will be made | |
207 | in the summary report. To see all of the parse errors, set this argument to | |
208 | true: | |
209 | ||
210 | errors => 1 | |
211 | ||
212 | =item * C<directives> | |
213 | ||
214 | If set to a true value, only test results with directives will be displayed. | |
215 | This overrides other settings such as C<verbose> or C<failures>. | |
216 | ||
217 | =item * C<stdout> | |
218 | ||
219 | A filehandle for catching standard output. | |
220 | ||
221 | =back | |
222 | ||
223 | Any keys for which the value is C<undef> will be ignored. | |
224 | ||
225 | =cut | |
226 | ||
227 | # new supplied by TAP::Base | |
228 | ||
229 | { | |
230 | my @legal_callback = qw( | |
231 | parser_args | |
232 | made_parser | |
233 | before_runtests | |
234 | after_runtests | |
235 | after_test | |
236 | ); | |
237 | ||
238 | sub _initialize { | |
239 | my ( $self, $arg_for ) = @_; | |
240 | $arg_for ||= {}; | |
241 | ||
242 | $self->SUPER::_initialize( $arg_for, \@legal_callback ); | |
243 | my %arg_for = %$arg_for; # force a shallow copy | |
244 | ||
245 | for my $name ( sort keys %VALIDATION_FOR ) { | |
246 | my $property = delete $arg_for{$name}; | |
247 | if ( defined $property ) { | |
248 | my $validate = $VALIDATION_FOR{$name}; | |
249 | ||
250 | my $value = $self->$validate($property); | |
251 | if ( $self->_error ) { | |
252 | $self->_croak; | |
253 | } | |
254 | $self->$name($value); | |
255 | } | |
256 | } | |
257 | ||
258 | $self->jobs(1) unless defined $self->jobs; | |
259 | ||
260 | unless ( $self->formatter ) { | |
261 | ||
262 | $self->formatter_class( my $class = $self->formatter_class | |
263 | || 'TAP::Formatter::Console' ); | |
264 | ||
265 | croak "Bad module name $class" | |
266 | unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; | |
267 | ||
268 | eval "require $class"; | |
269 | $self->_croak("Can't load $class") if $@; | |
270 | ||
271 | # This is a little bodge to preserve legacy behaviour. It's | |
272 | # pretty horrible that we know which args are destined for | |
273 | # the formatter. | |
274 | my %formatter_args = ( jobs => $self->jobs ); | |
275 | for my $name (@FORMATTER_ARGS) { | |
276 | if ( defined( my $property = delete $arg_for{$name} ) ) { | |
277 | $formatter_args{$name} = $property; | |
278 | } | |
279 | } | |
280 | ||
281 | $self->formatter( $class->new( \%formatter_args ) ); | |
282 | } | |
283 | ||
284 | if ( my @props = sort keys %arg_for ) { | |
285 | $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); | |
286 | } | |
287 | ||
288 | return $self; | |
289 | } | |
290 | } | |
291 | ||
292 | ############################################################################## | |
293 | ||
294 | =head2 Instance Methods | |
295 | ||
296 | =head3 C<runtests> | |
297 | ||
298 | $harness->runtests(@tests); | |
299 | ||
300 | Accepts and array of C<@tests> to be run. This should generally be the names | |
301 | of test files, but this is not required. Each element in C<@tests> will be | |
302 | passed to C<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> for more | |
303 | information. | |
304 | ||
305 | It is possible to provide aliases that will be displayed in place of the | |
306 | test name by supplying the test as a reference to an array containing | |
307 | C<< [ $test, $alias ] >>: | |
308 | ||
309 | $harness->runtests( [ 't/foo.t', 'Foo Once' ], | |
310 | [ 't/foo.t', 'Foo Twice' ] ); | |
311 | ||
312 | Normally it is an error to attempt to run the same test twice. Aliases | |
313 | allow you to overcome this limitation by giving each run of the test a | |
314 | unique name. | |
315 | ||
316 | Tests will be run in the order found. | |
317 | ||
318 | If the environment variable C<PERL_TEST_HARNESS_DUMP_TAP> is defined it | |
319 | should name a directory into which a copy of the raw TAP for each test | |
320 | will be written. TAP is written to files named for each test. | |
321 | Subdirectories will be created as needed. | |
322 | ||
323 | Returns a L<TAP::Parser::Aggregator> containing the test results. | |
324 | ||
325 | =cut | |
326 | ||
327 | sub runtests { | |
328 | my ( $self, @tests ) = @_; | |
329 | ||
330 | my $aggregate = TAP::Parser::Aggregator->new; | |
331 | ||
332 | $self->_make_callback( 'before_runtests', $aggregate ); | |
53bc175b | 333 | $aggregate->start; |
b965d173 | 334 | $self->aggregate_tests( $aggregate, @tests ); |
53bc175b | 335 | $aggregate->stop; |
b965d173 NC |
336 | $self->formatter->summary($aggregate); |
337 | $self->_make_callback( 'after_runtests', $aggregate ); | |
338 | ||
339 | return $aggregate; | |
340 | } | |
341 | ||
b965d173 NC |
342 | sub _after_test { |
343 | my ( $self, $aggregate, $test, $parser ) = @_; | |
344 | ||
345 | $self->_make_callback( 'after_test', $test, $parser ); | |
346 | $aggregate->add( $test->[1], $parser ); | |
347 | } | |
348 | ||
349 | sub _aggregate_forked { | |
350 | my ( $self, $aggregate, @tests ) = @_; | |
351 | ||
352 | eval { require Parallel::Iterator }; | |
353 | ||
354 | croak "Parallel::Iterator required for --fork option ($@)" | |
355 | if $@; | |
356 | ||
357 | my $iter = Parallel::Iterator::iterate( | |
358 | { workers => $self->jobs || 0 }, | |
359 | sub { | |
360 | my ( $id, $test ) = @_; | |
361 | ||
362 | my ( $parser, $session ) = $self->make_parser($test); | |
363 | ||
364 | while ( defined( my $result = $parser->next ) ) { | |
365 | exit 1 if $result->is_bailout; | |
366 | } | |
367 | ||
368 | $self->finish_parser( $parser, $session ); | |
369 | ||
370 | # Can't serialise coderefs... | |
371 | delete $parser->{_iter}; | |
372 | delete $parser->{_stream}; | |
373 | delete $parser->{_grammar}; | |
374 | return $parser; | |
375 | }, | |
376 | \@tests | |
377 | ); | |
378 | ||
379 | while ( my ( $id, $parser ) = $iter->() ) { | |
380 | $self->_after_test( $aggregate, $tests[$id], $parser ); | |
381 | } | |
382 | ||
383 | return; | |
384 | } | |
385 | ||
386 | sub _aggregate_parallel { | |
387 | my ( $self, $aggregate, @tests ) = @_; | |
388 | ||
389 | my $jobs = $self->jobs; | |
390 | my $mux = TAP::Parser::Multiplexer->new; | |
391 | ||
392 | RESULT: { | |
393 | ||
394 | # Keep multiplexer topped up | |
395 | while ( @tests && $mux->parsers < $jobs ) { | |
396 | my $test = shift @tests; | |
397 | my ( $parser, $session ) = $self->make_parser($test); | |
398 | $mux->add( $parser, [ $session, $test ] ); | |
399 | } | |
400 | ||
401 | if ( my ( $parser, $stash, $result ) = $mux->next ) { | |
402 | my ( $session, $test ) = @$stash; | |
403 | if ( defined $result ) { | |
404 | $session->result($result); | |
405 | exit 1 if $result->is_bailout; | |
406 | } | |
407 | else { | |
408 | ||
409 | # End of parser. Automatically removed from the mux. | |
410 | $self->finish_parser( $parser, $session ); | |
411 | $self->_after_test( $aggregate, $test, $parser ); | |
412 | } | |
413 | redo RESULT; | |
414 | } | |
415 | } | |
416 | ||
417 | return; | |
418 | } | |
419 | ||
420 | sub _aggregate_single { | |
421 | my ( $self, $aggregate, @tests ) = @_; | |
422 | ||
423 | for my $test (@tests) { | |
424 | my ( $parser, $session ) = $self->make_parser($test); | |
425 | ||
426 | while ( defined( my $result = $parser->next ) ) { | |
427 | $session->result($result); | |
69f36734 AA |
428 | if ( $result->is_bailout ) { |
429 | ||
430 | # Keep reading until input is exhausted in the hope | |
431 | # of allowing any pending diagnostics to show up. | |
432 | 1 while $parser->next; | |
433 | exit 1; | |
434 | } | |
b965d173 NC |
435 | } |
436 | ||
437 | $self->finish_parser( $parser, $session ); | |
438 | $self->_after_test( $aggregate, $test, $parser ); | |
439 | } | |
440 | ||
441 | return; | |
442 | } | |
443 | ||
53bc175b RGS |
444 | =head3 C<aggregate_tests> |
445 | ||
446 | $harness->aggregate_tests( $aggregate, @tests ); | |
447 | ||
448 | Run the named tests and display a summary of result. Tests will be run | |
449 | in the order found. | |
450 | ||
451 | Test results will be added to the supplied L<TAP::Parser::Aggregator>. | |
452 | C<aggregate_tests> may be called multiple times to run several sets of | |
453 | tests. Multiple C<Test::Harness> instances may be used to pass results | |
454 | to a single aggregator so that different parts of a complex test suite | |
455 | may be run using different C<TAP::Harness> settings. This is useful, for | |
456 | example, in the case where some tests should run in parallel but others | |
457 | are unsuitable for parallel execution. | |
458 | ||
459 | my $formatter = TAP::Formatter::Console->new; | |
460 | my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); | |
461 | my $par_harness = TAP::Harness->new( { formatter => $formatter, | |
462 | jobs => 9 } ); | |
463 | my $aggregator = TAP::Parser::Aggregator->new; | |
464 | ||
465 | $aggregator->start(); | |
466 | $ser_harness->aggregate_tests( $aggregator, @ser_tests ); | |
467 | $par_harness->aggregate_tests( $aggregator, @par_tests ); | |
468 | $aggregator->stop(); | |
469 | $formatter->summary( $aggregator ); | |
470 | ||
471 | Note that for simpler testing requirements it will often be possible to | |
472 | replace the above code with a single call to C<runtests>. | |
473 | ||
474 | Each elements of the @tests array is either | |
475 | ||
476 | =over | |
477 | ||
478 | =item * the file name of a test script to run | |
479 | ||
480 | =item * a reference to a [ file name, display name ] | |
481 | ||
482 | =back | |
483 | ||
484 | When you supply a separate display name it becomes possible to run a | |
485 | test more than once; the display name is effectively the alias by which | |
486 | the test is known inside the harness. The harness doesn't care if it | |
bd3ac2f1 | 487 | runs the same script more than once when each invocation uses a |
53bc175b RGS |
488 | different name. |
489 | ||
490 | =cut | |
491 | ||
b965d173 NC |
492 | sub aggregate_tests { |
493 | my ( $self, $aggregate, @tests ) = @_; | |
494 | ||
495 | my $jobs = $self->jobs; | |
496 | ||
497 | my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests; | |
498 | ||
bd3ac2f1 SP |
499 | # #12458 |
500 | local $ENV{HARNESS_IS_VERBOSE} = 1 | |
501 | if $self->formatter->verbosity > 0; | |
502 | ||
b965d173 NC |
503 | # Formatter gets only names |
504 | $self->formatter->prepare( map { $_->[1] } @expanded ); | |
b965d173 NC |
505 | |
506 | if ( $self->jobs > 1 ) { | |
507 | if ( $self->fork ) { | |
508 | $self->_aggregate_forked( $aggregate, @expanded ); | |
509 | } | |
510 | else { | |
511 | $self->_aggregate_parallel( $aggregate, @expanded ); | |
512 | } | |
513 | } | |
514 | else { | |
515 | $self->_aggregate_single( $aggregate, @expanded ); | |
516 | } | |
517 | ||
b965d173 NC |
518 | return; |
519 | } | |
520 | ||
521 | =head3 C<jobs> | |
522 | ||
523 | Returns the number of concurrent test runs the harness is handling. For the default | |
524 | harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel> | |
525 | will override this to return the number of jobs it is handling. | |
526 | ||
527 | =head3 C<fork> | |
528 | ||
529 | If true the harness will attempt to fork and run the parser for each | |
530 | test in a separate process. Currently this option requires | |
531 | L<Parallel::Iterator> to be installed. | |
532 | ||
533 | =cut | |
534 | ||
535 | ############################################################################## | |
536 | ||
537 | =head1 SUBCLASSING | |
538 | ||
539 | C<TAP::Harness> is designed to be (mostly) easy to subclass. If you don't | |
540 | like how a particular feature functions, just override the desired methods. | |
541 | ||
542 | =head2 Methods | |
543 | ||
544 | TODO: This is out of date | |
545 | ||
546 | The following methods are ones you may wish to override if you want to | |
547 | subclass C<TAP::Harness>. | |
548 | ||
549 | =head3 C<summary> | |
550 | ||
551 | $harness->summary( \%args ); | |
552 | ||
553 | C<summary> prints the summary report after all tests are run. The argument is | |
554 | a hashref with the following keys: | |
555 | ||
556 | =over 4 | |
557 | ||
558 | =item * C<start> | |
559 | ||
560 | This is created with C<< Benchmark->new >> and it the time the tests started. | |
561 | You can print a useful summary time, if desired, with: | |
562 | ||
563 | $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' )); | |
564 | ||
565 | =item * C<tests> | |
566 | ||
567 | This is an array reference of all test names. To get the L<TAP::Parser> | |
568 | object for individual tests: | |
569 | ||
570 | my $aggregate = $args->{aggregate}; | |
571 | my $tests = $args->{tests}; | |
572 | ||
573 | for my $name ( @$tests ) { | |
574 | my ($parser) = $aggregate->parsers($test); | |
575 | ... do something with $parser | |
576 | } | |
577 | ||
578 | This is a bit clunky and will be cleaned up in a later release. | |
579 | ||
580 | =back | |
581 | ||
582 | =cut | |
583 | ||
584 | sub _get_parser_args { | |
585 | my ( $self, $test ) = @_; | |
586 | my $test_prog = $test->[0]; | |
587 | my %args = (); | |
588 | my @switches; | |
589 | @switches = $self->lib if $self->lib; | |
590 | push @switches => $self->switches if $self->switches; | |
591 | $args{switches} = \@switches; | |
592 | $args{spool} = $self->_open_spool($test_prog); | |
593 | $args{merge} = $self->merge; | |
594 | $args{exec} = $self->exec; | |
595 | ||
596 | if ( my $exec = $self->exec ) { | |
597 | $args{exec} = [ @$exec, $test_prog ]; | |
598 | } | |
599 | else { | |
600 | $args{source} = $test_prog; | |
601 | } | |
602 | ||
603 | if ( defined( my $test_args = $self->test_args ) ) { | |
604 | $args{test_args} = $test_args; | |
605 | } | |
606 | ||
607 | return \%args; | |
608 | } | |
609 | ||
610 | =head3 C<make_parser> | |
611 | ||
612 | Make a new parser and display formatter session. Typically used and/or | |
613 | overridden in subclasses. | |
614 | ||
615 | my ( $parser, $session ) = $harness->make_parser; | |
616 | ||
617 | ||
618 | =cut | |
619 | ||
620 | sub make_parser { | |
621 | my ( $self, $test ) = @_; | |
622 | ||
623 | my $args = $self->_get_parser_args($test); | |
624 | $self->_make_callback( 'parser_args', $args, $test ); | |
625 | my $parser = TAP::Parser->new($args); | |
626 | ||
627 | $self->_make_callback( 'made_parser', $parser, $test ); | |
628 | my $session = $self->formatter->open_test( $test->[1], $parser ); | |
629 | ||
630 | return ( $parser, $session ); | |
631 | } | |
632 | ||
633 | =head3 C<finish_parser> | |
634 | ||
635 | Terminate use of a parser. Typically used and/or overridden in | |
636 | subclasses. The parser isn't destroyed as a result of this. | |
637 | ||
638 | =cut | |
639 | ||
640 | sub finish_parser { | |
641 | my ( $self, $parser, $session ) = @_; | |
642 | ||
643 | $session->close_test; | |
644 | $self->_close_spool($parser); | |
645 | ||
646 | return $parser; | |
647 | } | |
648 | ||
649 | sub _open_spool { | |
650 | my $self = shift; | |
651 | my $test = shift; | |
652 | ||
653 | if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { | |
654 | ||
655 | my $spool = File::Spec->catfile( $spool_dir, $test ); | |
656 | ||
657 | # Make the directory | |
658 | my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); | |
659 | my $path = File::Spec->catpath( $vol, $dir, '' ); | |
660 | eval { mkpath($path) }; | |
661 | $self->_croak($@) if $@; | |
662 | ||
663 | my $spool_handle = IO::Handle->new; | |
664 | open( $spool_handle, ">$spool" ) | |
665 | or $self->_croak(" Can't write $spool ( $! ) "); | |
666 | ||
667 | return $spool_handle; | |
668 | } | |
669 | ||
670 | return; | |
671 | } | |
672 | ||
673 | sub _close_spool { | |
674 | my $self = shift; | |
675 | my ($parser) = @_; | |
676 | ||
677 | if ( my $spool_handle = $parser->delete_spool ) { | |
678 | close($spool_handle) | |
679 | or $self->_croak(" Error closing TAP spool file( $! ) \n "); | |
680 | } | |
681 | ||
682 | return; | |
683 | } | |
684 | ||
685 | sub _croak { | |
686 | my ( $self, $message ) = @_; | |
687 | unless ($message) { | |
688 | $message = $self->_error; | |
689 | } | |
690 | $self->SUPER::_croak($message); | |
691 | ||
692 | return; | |
693 | } | |
694 | ||
695 | =head1 REPLACING | |
696 | ||
697 | If you like the C<prove> utility and L<TAP::Parser> but you want your | |
698 | own harness, all you need to do is write one and provide C<new> and | |
699 | C<runtests> methods. Then you can use the C<prove> utility like so: | |
700 | ||
701 | prove --harness My::Test::Harness | |
702 | ||
703 | Note that while C<prove> accepts a list of tests (or things to be | |
704 | tested), C<new> has a fairly rich set of arguments. You'll probably want | |
705 | to read over this code carefully to see how all of them are being used. | |
706 | ||
707 | =head1 SEE ALSO | |
708 | ||
709 | L<Test::Harness> | |
710 | ||
711 | =cut | |
712 | ||
713 | 1; | |
714 | ||
715 | # vim:ts=4:sw=4:et:sta |