4 use vars qw($VERSION @ISA);
7 use TAP::Parser::Grammar ();
8 use TAP::Parser::Result ();
9 use TAP::Parser::ResultFactory ();
10 use TAP::Parser::Source ();
11 use TAP::Parser::Source::Perl ();
12 use TAP::Parser::Iterator ();
13 use TAP::Parser::IteratorFactory ();
15 use Carp qw( confess );
21 TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
31 my $DEFAULT_TAP_VERSION = 12;
32 my $MAX_TAP_VERSION = 13;
34 $ENV{TAP_VERSION} = $MAX_TAP_VERSION;
39 delete $ENV{TAP_VERSION};
42 BEGIN { # making accessors
62 iterator_factory_class
70 return $self->{$method} unless @_;
71 $self->{$method} = shift;
74 } # done making accessors
80 my $parser = TAP::Parser->new( { source => $source } );
82 while ( my $result = $parser->next ) {
83 print $result->as_string;
88 C<TAP::Parser> is designed to produce a proper parse of TAP output. For
89 an example of how to run tests through this module, see the simple
90 harnesses C<examples/>.
92 There's a wiki dedicated to the Test Anything Protocol:
94 L<http://testanything.org>
96 It includes the TAP::Parser Cookbook:
98 L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
106 my $parser = TAP::Parser->new(\%args);
108 Returns a new C<TAP::Parser> object.
110 The arguments should be a hashref with I<one> of the following keys:
116 This is the preferred method of passing arguments to the constructor. To
117 determine how to handle the source, the following steps are taken.
119 If the source contains a newline, it's assumed to be a string of raw TAP
122 If the source is a reference, it's assumed to be something to pass to
123 the L<TAP::Parser::Iterator::Stream> constructor. This is used
124 internally and you should not use it.
126 Otherwise, the parser does a C<-e> check to see if the source exists. If so,
127 it attempts to execute the source and read the output as a stream. This is by
128 far the preferred method of using the parser.
130 foreach my $file ( @test_files ) {
131 my $parser = TAP::Parser->new( { source => $file } );
132 # do stuff with the parser
137 The value should be the complete TAP output.
141 If passed an array reference, will attempt to create the iterator by
142 passing a L<TAP::Parser::Source> object to
143 L<TAP::Parser::Iterator::Source>, using the array reference strings as
144 the command arguments to L<IPC::Open3::open3|IPC::Open3>:
146 exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
148 Note that C<source> and C<exec> are mutually exclusive.
152 The following keys are optional.
158 If present, each callback corresponding to a given result type will be called
159 with the result as the argument if the C<run> method is used:
162 test => \&test_callback,
163 plan => \&plan_callback,
164 comment => \&comment_callback,
165 bailout => \&bailout_callback,
166 unknown => \&unknown_callback,
169 my $aggregator = TAP::Parser::Aggregator->new;
170 foreach my $file ( @test_files ) {
171 my $parser = TAP::Parser->new(
174 callbacks => \%callbacks,
178 $aggregator->add( $file, $parser );
183 If using a Perl file as a source, optional switches may be passed which will
184 be used when invoking the perl executable.
186 my $parser = TAP::Parser->new( {
187 source => $test_file,
193 Used in conjunction with the C<source> option to supply a reference to
194 an C<@ARGV> style array of arguments to pass to the test program.
198 If passed a filehandle will write a copy of all parsed TAP to that handle.
202 If false, STDERR is not captured (though it is 'relayed' to keep it
203 somewhat synchronized with STDOUT.)
205 If true, STDERR and STDOUT are the same filehandle. This may cause
206 breakage if STDERR contains anything resembling TAP format, but does
207 allow exact synchronization.
209 Subtleties of this behavior may be platform-dependent and may change in
212 =item * C<source_class>
214 This option was introduced to let you easily customize which I<source> class
215 the parser should use. It defaults to L<TAP::Parser::Source>.
217 See also L</make_source>.
219 =item * C<perl_source_class>
221 This option was introduced to let you easily customize which I<perl source>
222 class the parser should use. It defaults to L<TAP::Parser::Source::Perl>.
224 See also L</make_perl_source>.
226 =item * C<grammar_class>
228 This option was introduced to let you easily customize which I<grammar> class
229 the parser should use. It defaults to L<TAP::Parser::Grammar>.
231 See also L</make_grammar>.
233 =item * C<iterator_factory_class>
235 This option was introduced to let you easily customize which I<iterator>
236 factory class the parser should use. It defaults to
237 L<TAP::Parser::IteratorFactory>.
239 See also L</make_iterator>.
241 =item * C<result_factory_class>
243 This option was introduced to let you easily customize which I<result>
244 factory class the parser should use. It defaults to
245 L<TAP::Parser::ResultFactory>.
247 See also L</make_result>.
253 # new() implementation supplied by TAP::Base
255 # This should make overriding behaviour of the Parser in subclasses easier:
256 sub _default_source_class {'TAP::Parser::Source'}
257 sub _default_perl_source_class {'TAP::Parser::Source::Perl'}
258 sub _default_grammar_class {'TAP::Parser::Grammar'}
259 sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
260 sub _default_result_factory_class {'TAP::Parser::ResultFactory'}
262 ##############################################################################
264 =head2 Instance Methods
268 my $parser = TAP::Parser->new( { source => $file } );
269 while ( my $result = $parser->next ) {
270 print $result->as_string, "\n";
273 This method returns the results of the parsing, one result at a time. Note
274 that it is destructive. You can't rewind and examine previous results.
276 If callbacks are used, they will be issued before this call returns.
278 Each result returned is a subclass of L<TAP::Parser::Result>. See that
279 module and related classes for more information on how to use them.
285 return ( $self->{_iter} ||= $self->_iter )->();
288 ##############################################################################
294 This method merely runs the parser and parses all of the TAP.
300 while ( defined( my $result = $self->next ) ) {
306 ##############################################################################
308 =head3 C<make_source>
310 Make a new L<TAP::Parser::Source> object and return it. Passes through any
313 The C<source_class> can be customized, as described in L</new>.
315 =head3 C<make_perl_source>
317 Make a new L<TAP::Parser::Source::Perl> object and return it. Passes through
320 The C<perl_source_class> can be customized, as described in L</new>.
322 =head3 C<make_grammar>
324 Make a new L<TAP::Parser::Grammar> object and return it. Passes through any
327 The C<grammar_class> can be customized, as described in L</new>.
329 =head3 C<make_iterator>
331 Make a new L<TAP::Parser::Iterator> object using the parser's
332 L<TAP::Parser::IteratorFactory>, and return it. Passes through any arguments
335 The C<iterator_factory_class> can be customized, as described in L</new>.
337 =head3 C<make_result>
339 Make a new L<TAP::Parser::Result> object using the parser's
340 L<TAP::Parser::ResultFactory>, and return it. Passes through any arguments
343 The C<result_factory_class> can be customized, as described in L</new>.
347 # This should make overriding behaviour of the Parser in subclasses easier:
348 sub make_source { shift->source_class->new(@_); }
349 sub make_perl_source { shift->perl_source_class->new(@_); }
350 sub make_grammar { shift->grammar_class->new(@_); }
351 sub make_iterator { shift->iterator_factory_class->make_iterator(@_); }
352 sub make_result { shift->result_factory_class->make_result(@_); }
354 sub _iterator_for_source {
355 my ( $self, $source ) = @_;
357 # If the source has a get_stream method then use it. This makes it
358 # possible to pass a pre-existing source object to the parser's
360 if ( UNIVERSAL::can( $source, 'can' ) && $source->can('get_stream') ) {
361 return $source->get_stream($self);
364 return $self->iterator_factory_class->make_iterator($source);
370 # of the following, anything beginning with an underscore is strictly
371 # internal and should not be exposed.
373 version => $DEFAULT_TAP_VERSION,
374 plan => '', # the test plan (e.g., 1..3)
376 tests_run => 0, # actual current test numbers
377 results => [], # TAP parser results
382 actual_failed => [], # how many tests really failed
383 actual_passed => [], # how many tests really passed
384 todo_passed => [], # tests which unexpectedly succeed
385 parse_errors => [], # perfect TAP should have none
388 # We seem to have this list hanging around all over the place. We could
389 # probably get it from somewhere else to avoid the repetition.
390 my @legal_callback = qw(
403 my @class_overrides = qw(
407 iterator_factory_class
412 my ( $self, $arg_for ) = @_;
414 # everything here is basically designed to convert any TAP source to a
418 my %args = %{ $arg_for || {} };
420 $self->SUPER::_initialize( \%args, \@legal_callback );
422 # get any class overrides out first:
423 for my $key (@class_overrides) {
424 my $default_method = "_default_$key";
425 my $val = delete $args{$key} || $self->$default_method();
429 my $stream = delete $args{stream};
430 my $tap = delete $args{tap};
431 my $source = delete $args{source};
432 my $exec = delete $args{exec};
433 my $merge = delete $args{merge};
434 my $spool = delete $args{spool};
435 my $switches = delete $args{switches};
436 my $ignore_exit = delete $args{ignore_exit};
437 my @test_args = @{ delete $args{test_args} || [] };
439 if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
441 "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
445 if ( my @excess = sort keys %args ) {
446 $self->_croak("Unknown options: @excess");
450 $stream = $self->_iterator_for_source( [ split "\n" => $tap ] );
453 my $source = $self->make_source;
454 $source->source( [ @$exec, @test_args ] );
455 $source->merge($merge); # XXX should just be arguments?
456 $stream = $source->get_stream($self);
460 $stream = $self->_iterator_for_source($source);
462 elsif ( -e $source ) {
463 my $perl = $self->make_perl_source;
465 $perl->switches($switches)
468 $perl->merge($merge); # XXX args to new()?
469 $perl->source( [ $source, @test_args ] );
470 $stream = $perl->get_stream($self);
473 $self->_croak("Cannot determine source for $source");
478 $self->_croak('PANIC: could not determine stream');
481 while ( my ( $k, $v ) = each %initialize ) {
482 $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
485 $self->_stream($stream);
486 $self->_spool($spool);
487 $self->ignore_exit($ignore_exit);
493 =head1 INDIVIDUAL RESULTS
495 If you've read this far in the docs, you've seen this:
497 while ( my $result = $parser->next ) {
498 print $result->as_string;
501 Each result returned is a L<TAP::Parser::Result> subclass, referred to as
506 Basically, you fetch individual results from the TAP. The six types, with
507 examples of each, are as follows:
525 ok 3 - We should start with some foobar!
529 # Hope we don't use up the foobar.
533 Bail out! We ran out of foobar!
537 ... yo, this ain't TAP! ...
541 Each result fetched is a result object of a different type. There are common
542 methods to each result object and different types may have methods unique to
543 their type. Sometimes a type method may be overridden in a subclass, but its
544 use is guaranteed to be identical.
546 =head2 Common type methods
550 Returns the type of result, such as C<comment> or C<test>.
554 Prints a string representation of the token. This might not be the exact
555 output, however. Tests will have test numbers added if not present, TODO and
556 SKIP directives will be capitalized and, in general, things will be cleaned
557 up. If you need the original text for the token, see the C<raw> method.
561 Returns the original line of text which was parsed.
565 Indicates whether or not this is the test plan line.
569 Indicates whether or not this is a test line.
573 Indicates whether or not this is a comment. Comments will generally only
574 appear in the TAP stream if STDERR is merged to STDOUT. See the
579 Indicates whether or not this is bailout line.
583 Indicates whether or not the current item is a YAML block.
587 Indicates whether or not the current line could be parsed.
591 if ( $result->is_ok ) { ... }
593 Reports whether or not a given result has passed. Anything which is B<not> a
594 test result returns true. This is merely provided as a convenient shortcut
595 which allows you to do this:
597 my $parser = TAP::Parser->new( { source => $source } );
598 while ( my $result = $parser->next ) {
599 # only print failing results
600 print $result->as_string unless $result->is_ok;
603 =head2 C<plan> methods
605 if ( $result->is_plan ) { ... }
607 If the above evaluates as true, the following methods will be available on the
612 if ( $result->is_plan ) {
616 This is merely a synonym for C<as_string>.
620 my $directive = $result->directive;
622 If a SKIP directive is included with the plan, this method will return it.
624 1..0 # SKIP: why bother?
626 =head3 C<explanation>
628 my $explanation = $result->explanation;
630 If a SKIP directive was included with the plan, this method will return the
633 =head2 C<pragma> methods
635 if ( $result->is_pragma ) { ... }
637 If the above evaluates as true, the following methods will be available on the
642 Returns a list of pragmas each of which is a + or - followed by the
645 =head2 C<commment> methods
647 if ( $result->is_comment ) { ... }
649 If the above evaluates as true, the following methods will be available on the
654 if ( $result->is_comment ) {
655 my $comment = $result->comment;
656 print "I have something to say: $comment";
659 =head2 C<bailout> methods
661 if ( $result->is_bailout ) { ... }
663 If the above evaluates as true, the following methods will be available on the
666 =head3 C<explanation>
668 if ( $result->is_bailout ) {
669 my $explanation = $result->explanation;
670 print "We bailed out because ($explanation)";
673 If, and only if, a token is a bailout token, you can get an "explanation" via
674 this method. The explanation is the text after the mystical "Bail out!" words
675 which appear in the tap output.
677 =head2 C<unknown> methods
679 if ( $result->is_unknown ) { ... }
681 There are no unique methods for unknown results.
683 =head2 C<test> methods
685 if ( $result->is_test ) { ... }
687 If the above evaluates as true, the following methods will be available on the
692 my $ok = $result->ok;
694 Returns the literal text of the C<ok> or C<not ok> status.
698 my $test_number = $result->number;
700 Returns the number of the test, even if the original TAP output did not supply
703 =head3 C<description>
705 my $description = $result->description;
707 Returns the description of the test, if any. This is the portion after the
708 test number but before the directive.
712 my $directive = $result->directive;
714 Returns either C<TODO> or C<SKIP> if either directive was present for a test
717 =head3 C<explanation>
719 my $explanation = $result->explanation;
721 If a test had either a C<TODO> or C<SKIP> directive, this method will return
722 the accompanying explantion, if present.
724 not ok 17 - 'Pigs can fly' # TODO not enough acid
726 For the above line, the explanation is I<not enough acid>.
730 if ( $result->is_ok ) { ... }
732 Returns a boolean value indicating whether or not the test passed. Remember
733 that for TODO tests, the test always passes.
735 B<Note:> this was formerly C<passed>. The latter method is deprecated and
736 will issue a warning.
738 =head3 C<is_actual_ok>
740 if ( $result->is_actual_ok ) { ... }
742 Returns a boolean value indicating whether or not the test passed, regardless
745 B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
746 and will issue a warning.
748 =head3 C<is_unplanned>
750 if ( $test->is_unplanned ) { ... }
752 If a test number is greater than the number of planned tests, this method will
753 return true. Unplanned tests will I<always> return false for C<is_ok>,
754 regardless of whether or not the test C<has_todo> (see
755 L<TAP::Parser::Result::Test> for more information about this).
759 if ( $result->has_skip ) { ... }
761 Returns a boolean value indicating whether or not this test had a SKIP
766 if ( $result->has_todo ) { ... }
768 Returns a boolean value indicating whether or not this test had a TODO
771 Note that TODO tests I<always> pass. If you need to know whether or not
772 they really passed, check the C<is_actual_ok> method.
776 if ( $parser->in_todo ) { ... }
778 True while the most recent result was a TODO. Becomes true before the
779 TODO result is returned and stays true until just before the next non-
780 TODO test is returned.
784 After parsing the TAP, there are many methods available to let you dig through
785 the results and determine what is meaningful to you.
787 =head2 Individual Results
789 These results refer to individual tests which are run.
793 my @passed = $parser->passed; # the test numbers which passed
794 my $passed = $parser->passed; # the number of tests which passed
796 This method lets you know which (or how many) tests passed. If a test failed
797 but had a TODO directive, it will be counted as a passed test.
801 sub passed { @{ shift->{passed} } }
805 my @failed = $parser->failed; # the test numbers which failed
806 my $failed = $parser->failed; # the number of tests which failed
808 This method lets you know which (or how many) tests failed. If a test passed
809 but had a TODO directive, it will B<NOT> be counted as a failed test.
813 sub failed { @{ shift->{failed} } }
815 =head3 C<actual_passed>
817 # the test numbers which actually passed
818 my @actual_passed = $parser->actual_passed;
820 # the number of tests which actually passed
821 my $actual_passed = $parser->actual_passed;
823 This method lets you know which (or how many) tests actually passed,
824 regardless of whether or not a TODO directive was found.
828 sub actual_passed { @{ shift->{actual_passed} } }
829 *actual_ok = \&actual_passed;
833 This method is a synonym for C<actual_passed>.
835 =head3 C<actual_failed>
837 # the test numbers which actually failed
838 my @actual_failed = $parser->actual_failed;
840 # the number of tests which actually failed
841 my $actual_failed = $parser->actual_failed;
843 This method lets you know which (or how many) tests actually failed,
844 regardless of whether or not a TODO directive was found.
848 sub actual_failed { @{ shift->{actual_failed} } }
850 ##############################################################################
854 my @todo = $parser->todo; # the test numbers with todo directives
855 my $todo = $parser->todo; # the number of tests with todo directives
857 This method lets you know which (or how many) tests had TODO directives.
861 sub todo { @{ shift->{todo} } }
863 =head3 C<todo_passed>
865 # the test numbers which unexpectedly succeeded
866 my @todo_passed = $parser->todo_passed;
868 # the number of tests which unexpectedly succeeded
869 my $todo_passed = $parser->todo_passed;
871 This method lets you know which (or how many) tests actually passed but were
872 declared as "TODO" tests.
876 sub todo_passed { @{ shift->{todo_passed} } }
878 ##############################################################################
880 =head3 C<todo_failed>
882 # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
884 This was a badly misnamed method. It indicates which TODO tests unexpectedly
885 succeeded. Will now issue a warning and call C<todo_passed>.
891 '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
897 my @skipped = $parser->skipped; # the test numbers with SKIP directives
898 my $skipped = $parser->skipped; # the number of tests with SKIP directives
900 This method lets you know which (or how many) tests had SKIP directives.
904 sub skipped { @{ shift->{skipped} } }
910 Get or set a pragma. To get the state of a pragma:
912 if ( $p->pragma('strict') ) {
916 To set the state of a pragma:
918 $p->pragma('strict', 1); # enable strict mode
923 my ( $self, $pragma ) = splice @_, 0, 2;
925 return $self->{pragma}->{$pragma} unless @_;
927 if ( my $state = shift ) {
928 $self->{pragma}->{$pragma} = 1;
931 delete $self->{pragma}->{$pragma};
939 Get a list of all the currently enabled pragmas:
941 my @pragmas_enabled = $p->pragmas;
945 sub pragmas { sort keys %{ shift->{pragma} || {} } }
947 =head2 Summary Results
949 These results are "meta" information about the total results of an individual
954 my $plan = $parser->plan;
956 Returns the test plan, if found.
960 Deprecated. Use C<is_good_plan> instead.
965 warn 'good_plan() is deprecated. Please use "is_good_plan()"';
969 ##############################################################################
971 =head3 C<is_good_plan>
973 if ( $parser->is_good_plan ) { ... }
975 Returns a boolean value indicating whether or not the number of tests planned
976 matches the number of tests run.
978 B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
979 will issue a warning.
981 And since we're on that subject ...
983 =head3 C<tests_planned>
985 print $parser->tests_planned;
987 Returns the number of tests planned, according to the plan. For example, a
988 plan of '1..17' will mean that 17 tests were planned.
992 print $parser->tests_run;
994 Returns the number of tests which actually were run. Hopefully this will
995 match the number of C<< $parser->tests_planned >>.
999 Returns a true value (actually the reason for skipping) if all tests
1002 =head3 C<start_time>
1004 Returns the time when the Parser was created.
1008 Returns the time when the end of TAP input was seen.
1010 =head3 C<has_problems>
1012 if ( $parser->has_problems ) {
1016 This is a 'catch-all' method which returns true if any tests have currently
1017 failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
1025 || $self->parse_errors
1026 || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
1033 Once the parser is done, this will return the version number for the
1034 parsed TAP. Version numbers were introduced with TAP version 13 so if no
1035 version number is found version 12 is assumed.
1041 Once the parser is done, this will return the exit status. If the parser ran
1042 an executable, it returns the exit status of the executable.
1048 Once the parser is done, this will return the wait status. If the parser ran
1049 an executable, it returns the wait status of the executable. Otherwise, this
1050 mererely returns the C<exit> status.
1052 =head2 C<ignore_exit>
1054 $parser->ignore_exit(1);
1056 Tell the parser to ignore the exit status from the test when determining
1057 whether the test passed. Normally tests with non-zero exit status are
1058 considered to have failed even if all individual tests passed. In cases
1059 where it is not possible to control the exit value of the test script
1060 use this option to ignore it.
1064 sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
1066 =head3 C<parse_errors>
1068 my @errors = $parser->parse_errors; # the parser errors
1069 my $errors = $parser->parse_errors; # the number of parser_errors
1071 Fortunately, all TAP output is perfect. In the event that it is not, this
1072 method will return parser errors. Note that a junk line which the parser does
1073 not recognize is C<not> an error. This allows this parser to handle future
1074 versions of TAP. The following are all TAP errors reported by the parser:
1078 =item * Misplaced plan
1080 The plan (for example, '1..5'), must only come at the beginning or end of the
1087 =item * More than one plan
1090 ok 1 - input file opened
1091 not ok 2 - first line of the input valid # todo some data
1092 ok 3 read the rest of the file
1095 Right. Very funny. Don't do that.
1097 =item * Test numbers out of sequence
1100 ok 1 - input file opened
1101 not ok 2 - first line of the input valid # todo some data
1102 ok 2 read the rest of the file
1104 That last test line above should have the number '3' instead of '2'.
1106 Note that it's perfectly acceptable for some lines to have test numbers and
1107 others to not have them. However, when a test number is found, it must be in
1108 sequence. The following is also an error:
1111 ok 1 - input file opened
1112 not ok - first line of the input valid # todo some data
1113 ok 2 read the rest of the file
1118 ok - input file opened
1119 not ok - first line of the input valid # todo some data
1120 ok 3 read the rest of the file
1126 sub parse_errors { @{ shift->{parse_errors} } }
1129 my ( $self, $error ) = @_;
1130 push @{ $self->{parse_errors} } => $error;
1134 sub _make_state_table {
1137 my %planned_todo = ();
1139 # These transitions are defaults for all states
1140 my %state_globals = (
1147 'If TAP version is present it must be the first line of output'
1154 if ( $self->pragma('strict') ) {
1156 'Unknown TAP token: "' . $unk->raw . '"' );
1163 for my $pr ( $pragma->pragmas ) {
1164 if ( $pr =~ /^ ([-+])(\w+) $/x ) {
1165 $self->pragma( $2, $1 eq '+' );
1172 # Provides default elements for transitions
1173 my %state_defaults = (
1177 $self->tests_planned( $plan->tests_planned );
1178 $self->plan( $plan->plan );
1179 if ( $plan->has_skip ) {
1180 $self->skip_all( $plan->explanation
1181 || '(no reason given)' );
1184 $planned_todo{$_}++ for @{ $plan->todo_list };
1191 my ( $number, $tests_run )
1192 = ( $test->number, ++$self->{tests_run} );
1195 if ( defined $number && delete $planned_todo{$number} ) {
1196 $test->set_directive('TODO');
1199 my $has_todo = $test->has_todo;
1201 $self->in_todo($has_todo);
1202 if ( defined( my $tests_planned = $self->tests_planned ) ) {
1203 if ( $tests_run > $tests_planned ) {
1204 $test->is_unplanned(1);
1209 if ( $number != $tests_run ) {
1210 my $count = $tests_run;
1211 $self->_add_error( "Tests out of sequence. Found "
1212 . "($number) but expected ($count)" );
1216 $test->_number( $number = $tests_run );
1219 push @{ $self->{todo} } => $number if $has_todo;
1220 push @{ $self->{todo_passed} } => $number
1221 if $test->todo_passed;
1222 push @{ $self->{skipped} } => $number
1225 push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
1236 yaml => { act => sub { }, },
1239 # Each state contains a hash the keys of which match a token type. For
1241 # type there may be:
1242 # act A coderef to run
1243 # goto The new state to move to. Stay in this state if
1245 # continue Goto the new state and run the new state for the
1252 my $ver_num = $version->version;
1253 if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
1254 my $ver_min = $DEFAULT_TAP_VERSION + 1;
1256 "Explicit TAP version must be at least "
1257 . "$ver_min. Got version $ver_num" );
1258 $ver_num = $DEFAULT_TAP_VERSION;
1260 if ( $ver_num > $MAX_TAP_VERSION ) {
1262 "TAP specified version $ver_num but "
1263 . "we don't know about versions later "
1264 . "than $MAX_TAP_VERSION" );
1265 $ver_num = $MAX_TAP_VERSION;
1267 $self->version($ver_num);
1268 $self->_grammar->set_version($ver_num);
1272 plan => { goto => 'PLANNED' },
1273 test => { goto => 'UNPLANNED' },
1276 plan => { goto => 'PLANNED' },
1277 test => { goto => 'UNPLANNED' },
1280 test => { goto => 'PLANNED_AFTER_TEST' },
1285 'More than one plan found in TAP output');
1289 PLANNED_AFTER_TEST => {
1290 test => { goto => 'PLANNED_AFTER_TEST' },
1291 plan => { act => sub { }, continue => 'PLANNED' },
1292 yaml => { goto => 'PLANNED' },
1298 my $line = $self->plan;
1300 "Plan ($line) must be at the beginning "
1301 . "or end of the TAP output" );
1302 $self->is_good_plan(0);
1304 continue => 'PLANNED'
1306 plan => { continue => 'PLANNED' },
1309 test => { goto => 'UNPLANNED_AFTER_TEST' },
1310 plan => { goto => 'GOT_PLAN' },
1312 UNPLANNED_AFTER_TEST => {
1313 test => { act => sub { }, continue => 'UNPLANNED' },
1314 plan => { act => sub { }, continue => 'UNPLANNED' },
1315 yaml => { goto => 'PLANNED' },
1319 # Apply globals and defaults to state table
1320 for my $name ( keys %states ) {
1322 # Merge with globals
1323 my $st = { %state_globals, %{ $states{$name} } };
1326 for my $next ( sort keys %{$st} ) {
1327 if ( my $default = $state_defaults{$next} ) {
1328 for my $def ( sort keys %{$default} ) {
1329 $st->{$next}->{$def} ||= $default->{$def};
1334 # Stuff back in table
1335 $states{$name} = $st;
1341 =head3 C<get_select_handles>
1343 Get an a list of file handles which can be passed to C<select> to
1344 determine the readiness of this parser.
1348 sub get_select_handles { shift->_stream->get_select_handles }
1352 return $self->{_grammar} = shift if @_;
1354 return $self->{_grammar} ||= $self->make_grammar(
1355 { stream => $self->_stream,
1357 version => $self->version
1364 my $stream = $self->_stream;
1365 my $grammar = $self->_grammar;
1366 my $spool = $self->_spool;
1368 my $state_table = $self->_make_state_table;
1370 $self->start_time( $self->get_time );
1372 # Make next_state closure
1373 my $next_state = sub {
1375 my $type = $token->type;
1377 my $state_spec = $state_table->{$state}
1378 or die "Illegal state: $state";
1380 if ( my $next = $state_spec->{$type} ) {
1381 if ( my $act = $next->{act} ) {
1384 if ( my $cont = $next->{continue} ) {
1388 elsif ( my $goto = $next->{goto} ) {
1393 confess("Unhandled token type: $type\n");
1399 # Handle end of stream - which means either pop a block or finish
1400 my $end_handler = sub {
1401 $self->exit( $stream->exit );
1402 $self->wait( $stream->wait );
1407 # Finally make the closure that we return. For performance reasons
1408 # there are two versions of the returned function: one that handles
1409 # callbacks and one that does not.
1410 if ( $self->_has_callbacks ) {
1412 my $result = eval { $grammar->tokenize };
1413 $self->_add_error($@) if $@;
1415 if ( defined $result ) {
1416 $result = $next_state->($result);
1418 if ( my $code = $self->_callback_for( $result->type ) ) {
1419 $_->($result) for @{$code};
1422 $self->_make_callback( 'ELSE', $result );
1425 $self->_make_callback( 'ALL', $result );
1427 # Echo TAP to spool file
1428 print {$spool} $result->raw, "\n" if $spool;
1431 $result = $end_handler->();
1432 $self->_make_callback( 'EOF', $result )
1433 unless defined $result;
1441 my $result = eval { $grammar->tokenize };
1442 $self->_add_error($@) if $@;
1444 if ( defined $result ) {
1445 $result = $next_state->($result);
1447 # Echo TAP to spool file
1448 print {$spool} $result->raw, "\n" if $spool;
1451 $result = $end_handler->();
1462 $self->end_time( $self->get_time );
1465 $self->_stream(undef);
1466 $self->_grammar(undef);
1468 # If we just delete the iter we won't get a fault if it's recreated.
1469 # Instead we set it to a sub that returns an infinite
1470 # stream of undef. This segfaults on 5.5.4, presumably because
1471 # we're still executing the closure that gets replaced and it hasn't
1472 # been protected with a refcount.
1473 $self->{_iter} = sub {return}
1477 if ( !$self->plan ) {
1478 $self->_add_error('No plan found in TAP output');
1481 $self->is_good_plan(1) unless defined $self->is_good_plan;
1483 if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
1484 $self->is_good_plan(0);
1485 if ( defined( my $planned = $self->tests_planned ) ) {
1486 my $ran = $self->tests_run;
1488 "Bad plan. You planned $planned tests but ran $ran.");
1491 if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
1493 # this should never happen
1494 my $actual = $self->tests_run;
1495 my $passed = $self->passed;
1496 my $failed = $self->failed;
1497 $self->_croak( "Panic: planned test count ($actual) did not equal "
1498 . "sum of passed ($passed) and failed ($failed) tests!" );
1501 $self->is_good_plan(0) unless defined $self->is_good_plan;
1505 =head3 C<delete_spool>
1507 Delete and return the spool.
1509 my $fh = $parser->delete_spool;
1516 return delete $self->{_spool};
1519 ##############################################################################
1523 As mentioned earlier, a "callback" key may be added to the
1524 C<TAP::Parser> constructor. If present, each callback corresponding to a
1525 given result type will be called with the result as the argument if the
1526 C<run> method is used. The callback is expected to be a subroutine
1527 reference (or anonymous subroutine) which is invoked with the parser
1528 result as its argument.
1531 test => \&test_callback,
1532 plan => \&plan_callback,
1533 comment => \&comment_callback,
1534 bailout => \&bailout_callback,
1535 unknown => \&unknown_callback,
1538 my $aggregator = TAP::Parser::Aggregator->new;
1539 foreach my $file ( @test_files ) {
1540 my $parser = TAP::Parser->new(
1543 callbacks => \%callbacks,
1547 $aggregator->add( $file, $parser );
1550 Callbacks may also be added like this:
1552 $parser->callback( test => \&test_callback );
1553 $parser->callback( plan => \&plan_callback );
1555 The following keys allowed for callbacks. These keys are case-sensitive.
1561 Invoked if C<< $result->is_test >> returns true.
1565 Invoked if C<< $result->is_version >> returns true.
1569 Invoked if C<< $result->is_plan >> returns true.
1573 Invoked if C<< $result->is_comment >> returns true.
1577 Invoked if C<< $result->is_unknown >> returns true.
1581 Invoked if C<< $result->is_yaml >> returns true.
1585 Invoked if C<< $result->is_unknown >> returns true.
1589 If a result does not have a callback defined for it, this callback will
1590 be invoked. Thus, if all of the previous result types are specified as
1591 callbacks, this callback will I<never> be invoked.
1595 This callback will always be invoked and this will happen for each
1596 result after one of the above callbacks is invoked. For example, if
1597 L<Term::ANSIColor> is loaded, you could use the following to color your
1603 if ( $test->is_ok && not $test->directive ) {
1604 # normal passing test
1605 print color 'green';
1607 elsif ( !$test->is_ok ) { # even if it's TODO
1608 print color 'white on_red';
1610 elsif ( $test->has_skip ) {
1611 print color 'white on_blue';
1614 elsif ( $test->has_todo ) {
1615 print color 'white';
1619 # plan, comment, and so on (anything which isn't a test line)
1620 print color 'black on_white';
1624 print shift->as_string;
1625 print color 'reset';
1632 Invoked when there are no more lines to be parsed. Since there is no
1633 accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
1640 If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
1642 =head1 BACKWARDS COMPATABILITY
1644 The Perl-QA list attempted to ensure backwards compatability with
1645 L<Test::Harness>. However, there are some minor differences.
1653 A little-known feature of L<Test::Harness> is that it supported TODO
1657 ok 1 - We have liftoff
1658 not ok 2 - Anti-gravity device activated
1660 Under L<Test::Harness>, test number 2 would I<pass> because it was
1661 listed as a TODO test on the plan line. However, we are not aware of
1662 anyone actually using this feature and hard-coding test numbers is
1663 discouraged because it's very easy to add a test and break the test
1664 number sequence. This makes test suites very fragile. Instead, the
1665 following should be used:
1668 ok 1 - We have liftoff
1669 not ok 2 - Anti-gravity device activated # TODO
1671 =item * 'Missing' tests
1673 It rarely happens, but sometimes a harness might encounter
1682 L<Test::Harness> would report tests 3-14 as having failed. For the
1683 C<TAP::Parser>, these tests are not considered failed because they've
1684 never run. They're reported as parse failures (tests out of sequence).
1690 If you find you need to provide custom functionality (as you would have using
1691 L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
1692 designed to be easily subclassed.
1694 Before you start, it's important to know a few things:
1700 All C<TAP::*> objects inherit from L<TAP::Object>.
1704 Most C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
1708 Note that C<TAP::Parser> is designed to be the central 'maker' - ie: it is
1709 responsible for creating new objects in the C<TAP::Parser::*> namespace.
1711 This makes it possible for you to have a single point of configuring what
1712 subclasses should be used, which in turn means that in many cases you'll find
1713 you only need to sub-class one of the parser's components.
1717 By subclassing, you may end up overriding undocumented methods. That's not
1718 a bad thing per se, but be forewarned that undocumented methods may change
1719 without warning from one release to the next - we cannot guarantee backwards
1720 compatability. If any I<documented> method needs changing, it will be
1721 deprecated first, and changed in a later release.
1725 =head2 Parser Components
1729 A TAP parser consumes input from a I<source>. There are currently two types
1730 of sources: L<TAP::Parser::Source> for general non-perl commands, and
1731 L<TAP::Parser::Source::Perl>. You can subclass both of them. You'll need to
1732 customize your parser by setting the C<source_class> & C<perl_source_class>
1733 parameters. See L</new> for more details.
1735 If you need to customize the objects on creation, subclass L<TAP::Parser> and
1736 override L</make_source> or L</make_perl_source>.
1740 A TAP parser uses I<iterators> to loop through the I<stream> provided by the
1741 parser's I<source>. There are quite a few types of Iterators available.
1742 Choosing which class to use is the responsibility of the I<iterator factory>.
1744 To create your own iterators you'll have to subclass
1745 L<TAP::Parser::IteratorFactory> and L<TAP::Parser::Iterator>. Then you'll
1746 need to customize the class used by your parser by setting the
1747 C<iterator_factory_class> parameter. See L</new> for more details.
1749 If you need to customize the objects on creation, subclass L<TAP::Parser> and
1750 override L</make_iterator>.
1754 A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
1755 input I<stream>. There are quite a few result types available; choosing
1756 which class to use is the responsibility of the I<result factory>.
1758 To create your own result types you have two options:
1764 Subclass L<TAP::Parser::Result> and register your new result type/class with
1765 the default L<TAP::Parser::ResultFactory>.
1769 Subclass L<TAP::Parser::ResultFactory> itself and implement your own
1770 L<TAP::Parser::Result> creation logic. Then you'll need to customize the
1771 class used by your parser by setting the C<result_factory_class> parameter.
1772 See L</new> for more details.
1776 If you need to customize the objects on creation, subclass L<TAP::Parser> and
1777 override L</make_result>.
1781 L<TAP::Parser::Grammar> is the heart of the parser - it tokenizes the TAP
1782 input I<stream> and produces results. If you need to customize its behaviour
1783 you should probably familiarize yourself with the source first. Enough
1786 Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
1787 C<grammar_class> parameter. See L</new> for more details.
1789 If you need to customize the objects on creation, subclass L<TAP::Parser> and
1790 override L</make_grammar>
1792 =head1 ACKNOWLEDGEMENTS
1794 All of the following have helped. Bug reports, patches, (im)moral
1795 support, or just words of encouragement have all been forthcoming.
1799 =item * Michael Schwern
1809 =item * Torsten Schoenfeld
1815 =item * Adam Kennedy
1819 =item * Adrian Howard
1823 =item * Andreas J. Koenig
1825 =item * Florian Ragwitz
1829 =item * Mark Stosberg
1833 =item * David Wheeler
1835 =item * Alex Vandiver
1841 Curtis "Ovid" Poe <ovid@cpan.org>
1843 Andy Armstong <andy@hexten.net>
1845 Eric Wilhelm @ <ewilhelm at cpan dot org>
1847 Michael Peters <mpeters at plusthree dot com>
1849 Leif Eriksen <leif dot eriksen at bigpond dot com>
1851 Steve Purkis <spurkis@cpan.org>
1855 Please report any bugs or feature requests to
1856 C<bug-test-harness@rt.cpan.org>, or through the web interface at
1857 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
1858 We will be notified, and then you'll automatically be notified of
1859 progress on your bug as we make changes.
1861 Obviously, bugs which include patches are best. If you prefer, you can
1862 patch against bleed by via anonymous checkout of the latest version:
1864 svn checkout http://svn.hexten.net/tapx
1866 =head1 COPYRIGHT & LICENSE
1868 Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
1870 This program is free software; you can redistribute it and/or modify it
1871 under the same terms as Perl itself.