Commit | Line | Data |
b965d173 |
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; |
b965d173 |
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 | |
a39e16d8 |
22 | Version 3.17 |
b965d173 |
23 | |
24 | =cut |
25 | |
a39e16d8 |
26 | $VERSION = '3.17'; |
b965d173 |
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( |
a39e16d8 |
63 | directives verbosity timer failures comments errors stdout color |
64 | show_count normalize |
b965d173 |
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 | }, |
27fc0087 |
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 }, |
27fc0087 |
84 | test_args => sub { shift; shift }, |
85 | ignore_exit => sub { shift; shift }, |
86 | rules => sub { shift; shift }, |
b965d173 |
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, |
a39e16d8 |
136 | lib => [ 'lib', 'blib/lib', 'blib/arch' ], |
b965d173 |
137 | ) |
138 | my $harness = TAP::Harness->new( \%args ); |
139 | |
27fc0087 |
140 | The constructor returns a new C<TAP::Harness> object. It accepts an |
141 | optional hashref whose allowed keys are: |
b965d173 |
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. |
27fc0087 |
154 | -3 silent Suppress everything. |
b965d173 |
155 | |
156 | =item * C<timer> |
157 | |
27fc0087 |
158 | Append run time for each test to output. Uses L<Time::HiRes> if |
159 | available. |
b965d173 |
160 | |
161 | =item * C<failures> |
162 | |
a39e16d8 |
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). |
b965d173 |
168 | |
27fc0087 |
169 | =item * C<show_count> |
170 | |
171 | Update the running test count during testing. |
172 | |
a39e16d8 |
173 | =item * C<normalize> |
174 | |
175 | Set to a true value to normalize the TAP that is emitted in verbose modes. |
176 | |
b965d173 |
177 | =item * C<lib> |
178 | |
27fc0087 |
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. |
b965d173 |
183 | |
184 | =item * C<switches> |
185 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
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: |
b965d173 |
204 | |
205 | exec => ['/usr/bin/ruby', '-w'] |
f7c69158 |
206 | |
27fc0087 |
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 | } |
f7c69158 |
223 | |
a39e16d8 |
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 | |
b965d173 |
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 | |
27fc0087 |
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 | |
b965d173 |
237 | =item * C<formatter_class> |
238 | |
239 | The name of the class to use to format output. The default is |
bdaf8c65 |
240 | L<TAP::Formatter::Console>, or L<TAP::Formatter::File> if the output |
241 | isn't a TTY. |
b965d173 |
242 | |
27fc0087 |
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 | |
b965d173 |
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 | |
27fc0087 |
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: |
b965d173 |
268 | |
269 | errors => 1 |
270 | |
271 | =item * C<directives> |
272 | |
27fc0087 |
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>. |
b965d173 |
276 | |
f7c69158 |
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 | |
27fc0087 |
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 | |
f7c69158 |
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 | |
b965d173 |
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 | |
27fc0087 |
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 | |
b965d173 |
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 | |
bdaf8c65 |
356 | local $default_class{formatter_class} = 'TAP::Formatter::File' |
a39e16d8 |
357 | unless -t ( $arg_for{stdout} || \*STDOUT ) && !$ENV{HARNESS_NOTTY}; |
bdaf8c65 |
358 | |
27fc0087 |
359 | while ( my ( $attr, $class ) = each %default_class ) { |
360 | $self->$attr( $self->$attr() || $class ); |
361 | } |
b965d173 |
362 | |
27fc0087 |
363 | unless ( $self->formatter ) { |
b965d173 |
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 | |
27fc0087 |
375 | $self->formatter( |
376 | $self->_construct( $self->formatter_class, \%formatter_args ) |
377 | ); |
b965d173 |
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 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
426 | my $aggregate = $self->_construct( $self->aggregator_class ); |
b965d173 |
427 | |
428 | $self->_make_callback( 'before_runtests', $aggregate ); |
53bc175b |
429 | $aggregate->start; |
b965d173 |
430 | $self->aggregate_tests( $aggregate, @tests ); |
53bc175b |
431 | $aggregate->stop; |
f7c69158 |
432 | $self->summary($aggregate); |
b965d173 |
433 | $self->_make_callback( 'after_runtests', $aggregate ); |
434 | |
435 | return $aggregate; |
436 | } |
437 | |
f7c69158 |
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 | |
b965d173 |
449 | sub _after_test { |
f7c69158 |
450 | my ( $self, $aggregate, $job, $parser ) = @_; |
b965d173 |
451 | |
f7c69158 |
452 | $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); |
453 | $aggregate->add( $job->description, $parser ); |
b965d173 |
454 | } |
455 | |
bdaf8c65 |
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 | |
b965d173 |
463 | sub _aggregate_parallel { |
f7c69158 |
464 | my ( $self, $aggregate, $scheduler ) = @_; |
b965d173 |
465 | |
466 | my $jobs = $self->jobs; |
27fc0087 |
467 | my $mux = $self->_construct( $self->multiplexer_class ); |
b965d173 |
468 | |
469 | RESULT: { |
470 | |
471 | # Keep multiplexer topped up |
f7c69158 |
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 ] ); |
b965d173 |
481 | } |
482 | |
483 | if ( my ( $parser, $stash, $result ) = $mux->next ) { |
f7c69158 |
484 | my ( $session, $job ) = @$stash; |
b965d173 |
485 | if ( defined $result ) { |
486 | $session->result($result); |
bdaf8c65 |
487 | $self->_bailout($result) if $result->is_bailout; |
b965d173 |
488 | } |
489 | else { |
490 | |
491 | # End of parser. Automatically removed from the mux. |
492 | $self->finish_parser( $parser, $session ); |
f7c69158 |
493 | $self->_after_test( $aggregate, $job, $parser ); |
494 | $job->finish; |
b965d173 |
495 | } |
496 | redo RESULT; |
497 | } |
498 | } |
499 | |
500 | return; |
501 | } |
502 | |
503 | sub _aggregate_single { |
f7c69158 |
504 | my ( $self, $aggregate, $scheduler ) = @_; |
b965d173 |
505 | |
f7c69158 |
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); |
b965d173 |
511 | |
512 | while ( defined( my $result = $parser->next ) ) { |
513 | $session->result($result); |
69f36734 |
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; |
bdaf8c65 |
519 | $self->_bailout($result); |
69f36734 |
520 | } |
b965d173 |
521 | } |
522 | |
523 | $self->finish_parser( $parser, $session ); |
f7c69158 |
524 | $self->_after_test( $aggregate, $job, $parser ); |
525 | $job->finish; |
b965d173 |
526 | } |
527 | |
528 | return; |
529 | } |
530 | |
53bc175b |
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 | |
27fc0087 |
546 | my $formatter = TAP::Formatter::Console->new; |
53bc175b |
547 | my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); |
27fc0087 |
548 | my $par_harness = TAP::Harness->new( |
549 | { formatter => $formatter, |
550 | jobs => 9 |
551 | } |
552 | ); |
53bc175b |
553 | my $aggregator = TAP::Parser::Aggregator->new; |
27fc0087 |
554 | |
53bc175b |
555 | $aggregator->start(); |
556 | $ser_harness->aggregate_tests( $aggregator, @ser_tests ); |
557 | $par_harness->aggregate_tests( $aggregator, @par_tests ); |
558 | $aggregator->stop(); |
27fc0087 |
559 | $formatter->summary($aggregator); |
53bc175b |
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 | |
f7c69158 |
570 | =item * a reference to a [ file name, display name ] array |
53bc175b |
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 |
bd3ac2f1 |
577 | runs the same script more than once when each invocation uses a |
53bc175b |
578 | different name. |
579 | |
580 | =cut |
581 | |
b965d173 |
582 | sub aggregate_tests { |
583 | my ( $self, $aggregate, @tests ) = @_; |
584 | |
f7c69158 |
585 | my $jobs = $self->jobs; |
586 | my $scheduler = $self->make_scheduler(@tests); |
b965d173 |
587 | |
bd3ac2f1 |
588 | # #12458 |
589 | local $ENV{HARNESS_IS_VERBOSE} = 1 |
590 | if $self->formatter->verbosity > 0; |
591 | |
f7c69158 |
592 | # Formatter gets only names. |
593 | $self->formatter->prepare( map { $_->description } $scheduler->get_all ); |
b965d173 |
594 | |
595 | if ( $self->jobs > 1 ) { |
a39e16d8 |
596 | $self->_aggregate_parallel( $aggregate, $scheduler ); |
b965d173 |
597 | } |
598 | else { |
f7c69158 |
599 | $self->_aggregate_single( $aggregate, $scheduler ); |
b965d173 |
600 | } |
601 | |
b965d173 |
602 | return; |
603 | } |
604 | |
f7c69158 |
605 | sub _add_descriptions { |
606 | my $self = shift; |
607 | |
bdaf8c65 |
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 $_ ? $_ : [$_] } @_; |
f7c69158 |
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 ) = @_; |
27fc0087 |
625 | return $self->_construct( |
626 | $self->scheduler_class, |
f7c69158 |
627 | tests => [ $self->_add_descriptions(@tests) ], |
628 | rules => $self->rules |
629 | ); |
630 | } |
631 | |
b965d173 |
632 | =head3 C<jobs> |
633 | |
bdaf8c65 |
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. |
b965d173 |
637 | |
b965d173 |
638 | =cut |
639 | |
640 | ############################################################################## |
641 | |
642 | =head1 SUBCLASSING |
643 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
659 | C<summary> prints the summary report after all tests are run. The |
660 | argument is a hashref with the following keys: |
b965d173 |
661 | |
662 | =over 4 |
663 | |
664 | =item * C<start> |
665 | |
27fc0087 |
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: |
b965d173 |
668 | |
27fc0087 |
669 | $self->output( |
670 | timestr( timediff( Benchmark->new, $start_time ), 'nop' ) ); |
b965d173 |
671 | |
672 | =item * C<tests> |
673 | |
27fc0087 |
674 | This is an array reference of all test names. To get the L<TAP::Parser> |
b965d173 |
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 { |
f7c69158 |
692 | my ( $self, $job ) = @_; |
693 | my $test_prog = $job->filename; |
b965d173 |
694 | my %args = (); |
695 | my @switches; |
696 | @switches = $self->lib if $self->lib; |
697 | push @switches => $self->switches if $self->switches; |
f7c69158 |
698 | $args{switches} = \@switches; |
699 | $args{spool} = $self->_open_spool($test_prog); |
700 | $args{merge} = $self->merge; |
701 | $args{ignore_exit} = $self->ignore_exit; |
b965d173 |
702 | |
703 | if ( my $exec = $self->exec ) { |
f7c69158 |
704 | $args{exec} |
705 | = ref $exec eq 'CODE' |
706 | ? $exec->( $self, $test_prog ) |
707 | : [ @$exec, $test_prog ]; |
a39e16d8 |
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 | } |
b965d173 |
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 | |
b965d173 |
733 | =cut |
734 | |
735 | sub make_parser { |
f7c69158 |
736 | my ( $self, $job ) = @_; |
b965d173 |
737 | |
f7c69158 |
738 | my $args = $self->_get_parser_args($job); |
739 | $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); |
27fc0087 |
740 | my $parser = $self->_construct( $self->parser_class, $args ); |
b965d173 |
741 | |
f7c69158 |
742 | $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); |
743 | my $session = $self->formatter->open_test( $job->description, $parser ); |
b965d173 |
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 |