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 | |
27fc0087 |
22 | Version 3.14 |
b965d173 |
23 | |
24 | =cut |
25 | |
27fc0087 |
26 | $VERSION = '3.14'; |
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( |
27fc0087 |
63 | directives verbosity timer failures errors stdout color show_count |
b965d173 |
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 | }, |
27fc0087 |
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 }, |
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, |
136 | lib => [ 'lib', 'blib/lib' ], |
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 | |
163 | Only show test failures (this is a no-op if C<verbose> is selected). |
164 | |
27fc0087 |
165 | =item * C<show_count> |
166 | |
167 | Update the running test count during testing. |
168 | |
b965d173 |
169 | =item * C<lib> |
170 | |
27fc0087 |
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. |
b965d173 |
175 | |
176 | =item * C<switches> |
177 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
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: |
b965d173 |
196 | |
197 | exec => ['/usr/bin/ruby', '-w'] |
f7c69158 |
198 | |
27fc0087 |
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 | } |
f7c69158 |
215 | |
b965d173 |
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 | |
27fc0087 |
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 | |
b965d173 |
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 | |
27fc0087 |
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 | |
b965d173 |
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 | |
27fc0087 |
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: |
b965d173 |
256 | |
257 | errors => 1 |
258 | |
259 | =item * C<directives> |
260 | |
27fc0087 |
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>. |
b965d173 |
264 | |
f7c69158 |
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 | |
27fc0087 |
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 | |
f7c69158 |
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 | |
b965d173 |
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 | |
27fc0087 |
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 | |
b965d173 |
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 | |
27fc0087 |
350 | while ( my ( $attr, $class ) = each %default_class ) { |
351 | $self->$attr( $self->$attr() || $class ); |
352 | } |
b965d173 |
353 | |
27fc0087 |
354 | unless ( $self->formatter ) { |
b965d173 |
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 | |
27fc0087 |
366 | $self->formatter( |
367 | $self->_construct( $self->formatter_class, \%formatter_args ) |
368 | ); |
b965d173 |
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 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
417 | my $aggregate = $self->_construct( $self->aggregator_class ); |
b965d173 |
418 | |
419 | $self->_make_callback( 'before_runtests', $aggregate ); |
53bc175b |
420 | $aggregate->start; |
b965d173 |
421 | $self->aggregate_tests( $aggregate, @tests ); |
53bc175b |
422 | $aggregate->stop; |
f7c69158 |
423 | $self->summary($aggregate); |
b965d173 |
424 | $self->_make_callback( 'after_runtests', $aggregate ); |
425 | |
426 | return $aggregate; |
427 | } |
428 | |
f7c69158 |
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 | |
b965d173 |
440 | sub _after_test { |
f7c69158 |
441 | my ( $self, $aggregate, $job, $parser ) = @_; |
b965d173 |
442 | |
f7c69158 |
443 | $self->_make_callback( 'after_test', $job->as_array_ref, $parser ); |
444 | $aggregate->add( $job->description, $parser ); |
b965d173 |
445 | } |
446 | |
447 | sub _aggregate_forked { |
f7c69158 |
448 | my ( $self, $aggregate, $scheduler ) = @_; |
b965d173 |
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 { |
f7c69158 |
458 | my $job = shift; |
459 | |
460 | return if $job->is_spinner; |
b965d173 |
461 | |
f7c69158 |
462 | my ( $parser, $session ) = $self->make_parser($job); |
b965d173 |
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 | }, |
f7c69158 |
476 | sub { $scheduler->get_job } |
b965d173 |
477 | ); |
478 | |
f7c69158 |
479 | while ( my ( $job, $parser ) = $iter->() ) { |
480 | next if $job->is_spinner; |
481 | $self->_after_test( $aggregate, $job, $parser ); |
482 | $job->finish; |
b965d173 |
483 | } |
484 | |
485 | return; |
486 | } |
487 | |
488 | sub _aggregate_parallel { |
f7c69158 |
489 | my ( $self, $aggregate, $scheduler ) = @_; |
b965d173 |
490 | |
491 | my $jobs = $self->jobs; |
27fc0087 |
492 | my $mux = $self->_construct( $self->multiplexer_class ); |
b965d173 |
493 | |
494 | RESULT: { |
495 | |
496 | # Keep multiplexer topped up |
f7c69158 |
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 ] ); |
b965d173 |
506 | } |
507 | |
508 | if ( my ( $parser, $stash, $result ) = $mux->next ) { |
f7c69158 |
509 | my ( $session, $job ) = @$stash; |
b965d173 |
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 ); |
f7c69158 |
518 | $self->_after_test( $aggregate, $job, $parser ); |
519 | $job->finish; |
b965d173 |
520 | } |
521 | redo RESULT; |
522 | } |
523 | } |
524 | |
525 | return; |
526 | } |
527 | |
528 | sub _aggregate_single { |
f7c69158 |
529 | my ( $self, $aggregate, $scheduler ) = @_; |
b965d173 |
530 | |
f7c69158 |
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); |
b965d173 |
536 | |
537 | while ( defined( my $result = $parser->next ) ) { |
538 | $session->result($result); |
69f36734 |
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 | } |
b965d173 |
546 | } |
547 | |
548 | $self->finish_parser( $parser, $session ); |
f7c69158 |
549 | $self->_after_test( $aggregate, $job, $parser ); |
550 | $job->finish; |
b965d173 |
551 | } |
552 | |
553 | return; |
554 | } |
555 | |
53bc175b |
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 | |
27fc0087 |
571 | my $formatter = TAP::Formatter::Console->new; |
53bc175b |
572 | my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); |
27fc0087 |
573 | my $par_harness = TAP::Harness->new( |
574 | { formatter => $formatter, |
575 | jobs => 9 |
576 | } |
577 | ); |
53bc175b |
578 | my $aggregator = TAP::Parser::Aggregator->new; |
27fc0087 |
579 | |
53bc175b |
580 | $aggregator->start(); |
581 | $ser_harness->aggregate_tests( $aggregator, @ser_tests ); |
582 | $par_harness->aggregate_tests( $aggregator, @par_tests ); |
583 | $aggregator->stop(); |
27fc0087 |
584 | $formatter->summary($aggregator); |
53bc175b |
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 | |
f7c69158 |
595 | =item * a reference to a [ file name, display name ] array |
53bc175b |
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 |
bd3ac2f1 |
602 | runs the same script more than once when each invocation uses a |
53bc175b |
603 | different name. |
604 | |
605 | =cut |
606 | |
b965d173 |
607 | sub aggregate_tests { |
608 | my ( $self, $aggregate, @tests ) = @_; |
609 | |
f7c69158 |
610 | my $jobs = $self->jobs; |
611 | my $scheduler = $self->make_scheduler(@tests); |
b965d173 |
612 | |
bd3ac2f1 |
613 | # #12458 |
614 | local $ENV{HARNESS_IS_VERBOSE} = 1 |
615 | if $self->formatter->verbosity > 0; |
616 | |
f7c69158 |
617 | # Formatter gets only names. |
618 | $self->formatter->prepare( map { $_->description } $scheduler->get_all ); |
b965d173 |
619 | |
620 | if ( $self->jobs > 1 ) { |
621 | if ( $self->fork ) { |
f7c69158 |
622 | $self->_aggregate_forked( $aggregate, $scheduler ); |
b965d173 |
623 | } |
624 | else { |
f7c69158 |
625 | $self->_aggregate_parallel( $aggregate, $scheduler ); |
b965d173 |
626 | } |
627 | } |
628 | else { |
f7c69158 |
629 | $self->_aggregate_single( $aggregate, $scheduler ); |
b965d173 |
630 | } |
631 | |
b965d173 |
632 | return; |
633 | } |
634 | |
f7c69158 |
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 ) = @_; |
27fc0087 |
668 | return $self->_construct( |
669 | $self->scheduler_class, |
f7c69158 |
670 | tests => [ $self->_add_descriptions(@tests) ], |
671 | rules => $self->rules |
672 | ); |
673 | } |
674 | |
b965d173 |
675 | =head3 C<jobs> |
676 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
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. |
b965d173 |
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 | |
27fc0087 |
709 | C<summary> prints the summary report after all tests are run. The |
710 | argument is a hashref with the following keys: |
b965d173 |
711 | |
712 | =over 4 |
713 | |
714 | =item * C<start> |
715 | |
27fc0087 |
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: |
b965d173 |
718 | |
27fc0087 |
719 | $self->output( |
720 | timestr( timediff( Benchmark->new, $start_time ), 'nop' ) ); |
b965d173 |
721 | |
722 | =item * C<tests> |
723 | |
27fc0087 |
724 | This is an array reference of all test names. To get the L<TAP::Parser> |
b965d173 |
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 { |
f7c69158 |
742 | my ( $self, $job ) = @_; |
743 | my $test_prog = $job->filename; |
b965d173 |
744 | my %args = (); |
745 | my @switches; |
746 | @switches = $self->lib if $self->lib; |
747 | push @switches => $self->switches if $self->switches; |
f7c69158 |
748 | $args{switches} = \@switches; |
749 | $args{spool} = $self->_open_spool($test_prog); |
750 | $args{merge} = $self->merge; |
751 | $args{ignore_exit} = $self->ignore_exit; |
b965d173 |
752 | |
753 | if ( my $exec = $self->exec ) { |
f7c69158 |
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}; |
b965d173 |
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 | |
b965d173 |
778 | =cut |
779 | |
780 | sub make_parser { |
f7c69158 |
781 | my ( $self, $job ) = @_; |
b965d173 |
782 | |
f7c69158 |
783 | my $args = $self->_get_parser_args($job); |
784 | $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); |
27fc0087 |
785 | my $parser = $self->_construct( $self->parser_class, $args ); |
b965d173 |
786 | |
f7c69158 |
787 | $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); |
788 | my $session = $self->formatter->open_test( $job->description, $parser ); |
b965d173 |
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 |