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