4 use vars qw($VERSION @ISA);
7 use TAP::Parser::Grammar ();
8 use TAP::Parser::Result ();
9 use TAP::Parser::Source ();
10 use TAP::Parser::Source::Perl ();
11 use TAP::Parser::Iterator ();
13 use Carp qw( confess );
19 TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
29 my $DEFAULT_TAP_VERSION = 12;
30 my $MAX_TAP_VERSION = 13;
32 $ENV{TAP_VERSION} = $MAX_TAP_VERSION;
37 delete $ENV{TAP_VERSION};
40 BEGIN { # making accessors
63 # another tiny performance hack
64 if ( $method =~ /^_/ ) {
67 return $self->{$method} unless @_;
70 unless ( ( ref $self ) =~ /^TAP::Parser/ ) {
71 Carp::croak("$method() may not be set externally");
74 $self->{$method} = shift;
80 return $self->{$method} unless @_;
81 $self->{$method} = shift;
85 } # done making accessors
91 my $parser = TAP::Parser->new( { source => $source } );
93 while ( my $result = $parser->next ) {
94 print $result->as_string;
99 C<TAP::Parser> is designed to produce a proper parse of TAP output. For
100 an example of how to run tests through this module, see the simple
101 harnesses C<examples/>.
103 There's a wiki dedicated to the Test Anything Protocol:
105 L<http://testanything.org>
107 It includes the TAP::Parser Cookbook:
109 L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
117 my $parser = TAP::Parser->new(\%args);
119 Returns a new C<TAP::Parser> object.
121 The arguments should be a hashref with I<one> of the following keys:
127 This is the preferred method of passing arguments to the constructor. To
128 determine how to handle the source, the following steps are taken.
130 If the source contains a newline, it's assumed to be a string of raw TAP
133 If the source is a reference, it's assumed to be something to pass to
134 the L<TAP::Parser::Iterator::Stream> constructor. This is used
135 internally and you should not use it.
137 Otherwise, the parser does a C<-e> check to see if the source exists. If so,
138 it attempts to execute the source and read the output as a stream. This is by
139 far the preferred method of using the parser.
141 foreach my $file ( @test_files ) {
142 my $parser = TAP::Parser->new( { source => $file } );
143 # do stuff with the parser
148 The value should be the complete TAP output.
152 If passed an array reference, will attempt to create the iterator by
153 passing a L<TAP::Parser::Source> object to
154 L<TAP::Parser::Iterator::Source>, using the array reference strings as
155 the command arguments to L<IPC::Open3::open3|IPC::Open3>:
157 exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
159 Note that C<source> and C<exec> are mutually exclusive.
163 The following keys are optional.
169 If present, each callback corresponding to a given result type will be called
170 with the result as the argument if the C<run> method is used:
173 test => \&test_callback,
174 plan => \&plan_callback,
175 comment => \&comment_callback,
176 bailout => \&bailout_callback,
177 unknown => \&unknown_callback,
180 my $aggregator = TAP::Parser::Aggregator->new;
181 foreach my $file ( @test_files ) {
182 my $parser = TAP::Parser->new(
185 callbacks => \%callbacks,
189 $aggregator->add( $file, $parser );
194 If using a Perl file as a source, optional switches may be passed which will
195 be used when invoking the perl executable.
197 my $parser = TAP::Parser->new( {
198 source => $test_file,
204 Used in conjunction with the C<source> option to supply a reference to
205 an C<@ARGV> style array of arguments to pass to the test program.
209 If passed a filehandle will write a copy of all parsed TAP to that handle.
213 If false, STDERR is not captured (though it is 'relayed' to keep it
214 somewhat synchronized with STDOUT.)
216 If true, STDERR and STDOUT are the same filehandle. This may cause
217 breakage if STDERR contains anything resembling TAP format, but does
218 allow exact synchronization.
220 Subtleties of this behavior may be platform-dependent and may change in
227 # new implementation supplied by TAP::Base
229 ##############################################################################
231 =head2 Instance Methods
235 my $parser = TAP::Parser->new( { source => $file } );
236 while ( my $result = $parser->next ) {
237 print $result->as_string, "\n";
240 This method returns the results of the parsing, one result at a time. Note
241 that it is destructive. You can't rewind and examine previous results.
243 If callbacks are used, they will be issued before this call returns.
245 Each result returned is a subclass of L<TAP::Parser::Result>. See that
246 module and related classes for more information on how to use them.
252 return ( $self->{_iter} ||= $self->_iter )->();
255 ##############################################################################
261 This method merely runs the parser and parses all of the TAP.
267 while ( defined( my $result = $self->next ) ) {
275 # of the following, anything beginning with an underscore is strictly
276 # internal and should not be exposed.
278 version => $DEFAULT_TAP_VERSION,
279 plan => '', # the test plan (e.g., 1..3)
281 tests_run => 0, # actual current test numbers
282 results => [], # TAP parser results
287 actual_failed => [], # how many tests really failed
288 actual_passed => [], # how many tests really passed
289 todo_passed => [], # tests which unexpectedly succeed
290 parse_errors => [], # perfect TAP should have none
293 # We seem to have this list hanging around all over the place. We could
294 # probably get it from somewhere else to avoid the repetition.
295 my @legal_callback = qw(
309 my ( $self, $arg_for ) = @_;
311 # everything here is basically designed to convert any TAP source to a
315 my %args = %{ $arg_for || {} };
317 $self->SUPER::_initialize( \%args, \@legal_callback );
319 my $stream = delete $args{stream};
320 my $tap = delete $args{tap};
321 my $source = delete $args{source};
322 my $exec = delete $args{exec};
323 my $merge = delete $args{merge};
324 my $spool = delete $args{spool};
325 my $switches = delete $args{switches};
326 my @test_args = @{ delete $args{test_args} || [] };
328 if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
330 "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
334 if ( my @excess = sort keys %args ) {
335 $self->_croak("Unknown options: @excess");
339 $stream = TAP::Parser::Iterator->new( [ split "\n" => $tap ] );
342 my $source = TAP::Parser::Source->new;
343 $source->source( [ @$exec, @test_args ] );
344 $source->merge($merge); # XXX should just be arguments?
345 $stream = $source->get_stream;
348 if ( my $ref = ref $source ) {
349 $stream = TAP::Parser::Iterator->new($source);
351 elsif ( -e $source ) {
353 my $perl = TAP::Parser::Source::Perl->new;
355 $perl->switches($switches)
358 $perl->merge($merge); # XXX args to new()?
360 $perl->source( [ $source, @test_args ] );
362 $stream = $perl->get_stream;
365 $self->_croak("Cannot determine source for $source");
370 $self->_croak('PANIC: could not determine stream');
373 while ( my ( $k, $v ) = each %initialize ) {
374 $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
377 $self->_stream($stream);
378 my $grammar = TAP::Parser::Grammar->new($stream);
379 $grammar->set_version( $self->version );
380 $self->_grammar($grammar);
381 $self->_spool($spool);
383 $self->start_time( $self->get_time );
389 =head1 INDIVIDUAL RESULTS
391 If you've read this far in the docs, you've seen this:
393 while ( my $result = $parser->next ) {
394 print $result->as_string;
397 Each result returned is a L<TAP::Parser::Result> subclass, referred to as
402 Basically, you fetch individual results from the TAP. The six types, with
403 examples of each, are as follows:
421 ok 3 - We should start with some foobar!
425 # Hope we don't use up the foobar.
429 Bail out! We ran out of foobar!
433 ... yo, this ain't TAP! ...
437 Each result fetched is a result object of a different type. There are common
438 methods to each result object and different types may have methods unique to
439 their type. Sometimes a type method may be overridden in a subclass, but its
440 use is guaranteed to be identical.
442 =head2 Common type methods
446 Returns the type of result, such as C<comment> or C<test>.
450 Prints a string representation of the token. This might not be the exact
451 output, however. Tests will have test numbers added if not present, TODO and
452 SKIP directives will be capitalized and, in general, things will be cleaned
453 up. If you need the original text for the token, see the C<raw> method.
457 Returns the original line of text which was parsed.
461 Indicates whether or not this is the test plan line.
465 Indicates whether or not this is a test line.
469 Indicates whether or not this is a comment. Comments will generally only
470 appear in the TAP stream if STDERR is merged to STDOUT. See the
475 Indicates whether or not this is bailout line.
479 Indicates whether or not the current item is a YAML block.
483 Indicates whether or not the current line could be parsed.
487 if ( $result->is_ok ) { ... }
489 Reports whether or not a given result has passed. Anything which is B<not> a
490 test result returns true. This is merely provided as a convenient shortcut
491 which allows you to do this:
493 my $parser = TAP::Parser->new( { source => $source } );
494 while ( my $result = $parser->next ) {
495 # only print failing results
496 print $result->as_string unless $result->is_ok;
499 =head2 C<plan> methods
501 if ( $result->is_plan ) { ... }
503 If the above evaluates as true, the following methods will be available on the
508 if ( $result->is_plan ) {
512 This is merely a synonym for C<as_string>.
516 my $directive = $result->directive;
518 If a SKIP directive is included with the plan, this method will return it.
520 1..0 # SKIP: why bother?
522 =head3 C<explanation>
524 my $explanation = $result->explanation;
526 If a SKIP directive was included with the plan, this method will return the
529 =head2 C<pragma> methods
531 if ( $result->is_pragma ) { ... }
533 If the above evaluates as true, the following methods will be available on the
538 Returns a list of pragmas each of which is a + or - followed by the
541 =head2 C<commment> methods
543 if ( $result->is_comment ) { ... }
545 If the above evaluates as true, the following methods will be available on the
550 if ( $result->is_comment ) {
551 my $comment = $result->comment;
552 print "I have something to say: $comment";
555 =head2 C<bailout> methods
557 if ( $result->is_bailout ) { ... }
559 If the above evaluates as true, the following methods will be available on the
562 =head3 C<explanation>
564 if ( $result->is_bailout ) {
565 my $explanation = $result->explanation;
566 print "We bailed out because ($explanation)";
569 If, and only if, a token is a bailout token, you can get an "explanation" via
570 this method. The explanation is the text after the mystical "Bail out!" words
571 which appear in the tap output.
573 =head2 C<unknown> methods
575 if ( $result->is_unknown ) { ... }
577 There are no unique methods for unknown results.
579 =head2 C<test> methods
581 if ( $result->is_test ) { ... }
583 If the above evaluates as true, the following methods will be available on the
588 my $ok = $result->ok;
590 Returns the literal text of the C<ok> or C<not ok> status.
594 my $test_number = $result->number;
596 Returns the number of the test, even if the original TAP output did not supply
599 =head3 C<description>
601 my $description = $result->description;
603 Returns the description of the test, if any. This is the portion after the
604 test number but before the directive.
608 my $directive = $result->directive;
610 Returns either C<TODO> or C<SKIP> if either directive was present for a test
613 =head3 C<explanation>
615 my $explanation = $result->explanation;
617 If a test had either a C<TODO> or C<SKIP> directive, this method will return
618 the accompanying explantion, if present.
620 not ok 17 - 'Pigs can fly' # TODO not enough acid
622 For the above line, the explanation is I<not enough acid>.
626 if ( $result->is_ok ) { ... }
628 Returns a boolean value indicating whether or not the test passed. Remember
629 that for TODO tests, the test always passes.
631 B<Note:> this was formerly C<passed>. The latter method is deprecated and
632 will issue a warning.
634 =head3 C<is_actual_ok>
636 if ( $result->is_actual_ok ) { ... }
638 Returns a boolean value indicating whether or not the test passed, regardless
641 B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
642 and will issue a warning.
644 =head3 C<is_unplanned>
646 if ( $test->is_unplanned ) { ... }
648 If a test number is greater than the number of planned tests, this method will
649 return true. Unplanned tests will I<always> return false for C<is_ok>,
650 regardless of whether or not the test C<has_todo> (see
651 L<TAP::Parser::Result::Test> for more information about this).
655 if ( $result->has_skip ) { ... }
657 Returns a boolean value indicating whether or not this test had a SKIP
662 if ( $result->has_todo ) { ... }
664 Returns a boolean value indicating whether or not this test had a TODO
667 Note that TODO tests I<always> pass. If you need to know whether or not
668 they really passed, check the C<is_actual_ok> method.
672 if ( $parser->in_todo ) { ... }
674 True while the most recent result was a TODO. Becomes true before the
675 TODO result is returned and stays true until just before the next non-
676 TODO test is returned.
680 After parsing the TAP, there are many methods available to let you dig through
681 the results and determine what is meaningful to you.
683 =head2 Individual Results
685 These results refer to individual tests which are run.
689 my @passed = $parser->passed; # the test numbers which passed
690 my $passed = $parser->passed; # the number of tests which passed
692 This method lets you know which (or how many) tests passed. If a test failed
693 but had a TODO directive, it will be counted as a passed test.
697 sub passed { @{ shift->{passed} } }
701 my @failed = $parser->failed; # the test numbers which failed
702 my $failed = $parser->failed; # the number of tests which failed
704 This method lets you know which (or how many) tests failed. If a test passed
705 but had a TODO directive, it will B<NOT> be counted as a failed test.
709 sub failed { @{ shift->{failed} } }
711 =head3 C<actual_passed>
713 # the test numbers which actually passed
714 my @actual_passed = $parser->actual_passed;
716 # the number of tests which actually passed
717 my $actual_passed = $parser->actual_passed;
719 This method lets you know which (or how many) tests actually passed,
720 regardless of whether or not a TODO directive was found.
724 sub actual_passed { @{ shift->{actual_passed} } }
725 *actual_ok = \&actual_passed;
729 This method is a synonym for C<actual_passed>.
731 =head3 C<actual_failed>
733 # the test numbers which actually failed
734 my @actual_failed = $parser->actual_failed;
736 # the number of tests which actually failed
737 my $actual_failed = $parser->actual_failed;
739 This method lets you know which (or how many) tests actually failed,
740 regardless of whether or not a TODO directive was found.
744 sub actual_failed { @{ shift->{actual_failed} } }
746 ##############################################################################
750 my @todo = $parser->todo; # the test numbers with todo directives
751 my $todo = $parser->todo; # the number of tests with todo directives
753 This method lets you know which (or how many) tests had TODO directives.
757 sub todo { @{ shift->{todo} } }
759 =head3 C<todo_passed>
761 # the test numbers which unexpectedly succeeded
762 my @todo_passed = $parser->todo_passed;
764 # the number of tests which unexpectedly succeeded
765 my $todo_passed = $parser->todo_passed;
767 This method lets you know which (or how many) tests actually passed but were
768 declared as "TODO" tests.
772 sub todo_passed { @{ shift->{todo_passed} } }
774 ##############################################################################
776 =head3 C<todo_failed>
778 # deprecated in favor of 'todo_passed'. This method was horribly misnamed.
780 This was a badly misnamed method. It indicates which TODO tests unexpectedly
781 succeeded. Will now issue a warning and call C<todo_passed>.
787 '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
793 my @skipped = $parser->skipped; # the test numbers with SKIP directives
794 my $skipped = $parser->skipped; # the number of tests with SKIP directives
796 This method lets you know which (or how many) tests had SKIP directives.
800 sub skipped { @{ shift->{skipped} } }
806 Get or set a pragma. To get the state of a pragma:
808 if ( $p->pragma('strict') ) {
812 To set the state of a pragma:
814 $p->pragma('strict', 1); # enable strict mode
819 my ( $self, $pragma ) = splice @_, 0, 2;
821 return $self->{pragma}->{$pragma} unless @_;
823 if ( my $state = shift ) {
824 $self->{pragma}->{$pragma} = 1;
827 delete $self->{pragma}->{$pragma};
835 Get a list of all the currently enabled pragmas:
837 my @pragmas_enabled = $p->pragmas;
841 sub pragmas { sort keys %{ shift->{pragma} || {} } }
843 =head2 Summary Results
845 These results are "meta" information about the total results of an individual
850 my $plan = $parser->plan;
852 Returns the test plan, if found.
856 Deprecated. Use C<is_good_plan> instead.
861 warn 'good_plan() is deprecated. Please use "is_good_plan()"';
865 ##############################################################################
867 =head3 C<is_good_plan>
869 if ( $parser->is_good_plan ) { ... }
871 Returns a boolean value indicating whether or not the number of tests planned
872 matches the number of tests run.
874 B<Note:> this was formerly C<good_plan>. The latter method is deprecated and
875 will issue a warning.
877 And since we're on that subject ...
879 =head3 C<tests_planned>
881 print $parser->tests_planned;
883 Returns the number of tests planned, according to the plan. For example, a
884 plan of '1..17' will mean that 17 tests were planned.
888 print $parser->tests_run;
890 Returns the number of tests which actually were run. Hopefully this will
891 match the number of C<< $parser->tests_planned >>.
895 Returns a true value (actually the reason for skipping) if all tests
900 Returns the time when the Parser was created.
904 Returns the time when the end of TAP input was seen.
906 =head3 C<has_problems>
908 if ( $parser->has_problems ) {
912 This is a 'catch-all' method which returns true if any tests have currently
913 failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
921 || $self->parse_errors
930 Once the parser is done, this will return the version number for the
931 parsed TAP. Version numbers were introduced with TAP version 13 so if no
932 version number is found version 12 is assumed.
938 Once the parser is done, this will return the exit status. If the parser ran
939 an executable, it returns the exit status of the executable.
945 Once the parser is done, this will return the wait status. If the parser ran
946 an executable, it returns the wait status of the executable. Otherwise, this
947 mererely returns the C<exit> status.
949 =head3 C<parse_errors>
951 my @errors = $parser->parse_errors; # the parser errors
952 my $errors = $parser->parse_errors; # the number of parser_errors
954 Fortunately, all TAP output is perfect. In the event that it is not, this
955 method will return parser errors. Note that a junk line which the parser does
956 not recognize is C<not> an error. This allows this parser to handle future
957 versions of TAP. The following are all TAP errors reported by the parser:
961 =item * Misplaced plan
963 The plan (for example, '1..5'), must only come at the beginning or end of the
970 =item * More than one plan
973 ok 1 - input file opened
974 not ok 2 - first line of the input valid # todo some data
975 ok 3 read the rest of the file
978 Right. Very funny. Don't do that.
980 =item * Test numbers out of sequence
983 ok 1 - input file opened
984 not ok 2 - first line of the input valid # todo some data
985 ok 2 read the rest of the file
987 That last test line above should have the number '3' instead of '2'.
989 Note that it's perfectly acceptable for some lines to have test numbers and
990 others to not have them. However, when a test number is found, it must be in
991 sequence. The following is also an error:
994 ok 1 - input file opened
995 not ok - first line of the input valid # todo some data
996 ok 2 read the rest of the file
1001 ok - input file opened
1002 not ok - first line of the input valid # todo some data
1003 ok 3 read the rest of the file
1009 sub parse_errors { @{ shift->{parse_errors} } }
1012 my ( $self, $error ) = @_;
1013 push @{ $self->{parse_errors} } => $error;
1017 sub _make_state_table {
1020 my %planned_todo = ();
1022 # These transitions are defaults for all states
1023 my %state_globals = (
1030 'If TAP version is present it must be the first line of output'
1037 if ( $self->pragma('strict') ) {
1039 'Unknown TAP token: "' . $unk->raw . '"' );
1046 for my $pr ( $pragma->pragmas ) {
1047 if ( $pr =~ /^ ([-+])(\w+) $/x ) {
1048 $self->pragma( $2, $1 eq '+' );
1055 # Provides default elements for transitions
1056 my %state_defaults = (
1060 $self->tests_planned( $plan->tests_planned );
1061 $self->plan( $plan->plan );
1062 if ( $plan->has_skip ) {
1063 $self->skip_all( $plan->explanation
1064 || '(no reason given)' );
1067 $planned_todo{$_}++ for @{ $plan->todo_list };
1074 my ( $number, $tests_run )
1075 = ( $test->number, ++$self->{tests_run} );
1078 if ( defined $number && delete $planned_todo{$number} ) {
1079 $test->set_directive('TODO');
1082 my $has_todo = $test->has_todo;
1084 $self->in_todo($has_todo);
1085 if ( defined( my $tests_planned = $self->tests_planned ) ) {
1086 if ( $tests_run > $tests_planned ) {
1087 $test->is_unplanned(1);
1092 if ( $number != $tests_run ) {
1093 my $count = $tests_run;
1094 $self->_add_error( "Tests out of sequence. Found "
1095 . "($number) but expected ($count)" );
1099 $test->_number( $number = $tests_run );
1102 push @{ $self->{todo} } => $number if $has_todo;
1103 push @{ $self->{todo_passed} } => $number
1104 if $test->todo_passed;
1105 push @{ $self->{skipped} } => $number
1108 push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
1119 yaml => { act => sub { }, },
1122 # Each state contains a hash the keys of which match a token type. For
1124 # type there may be:
1125 # act A coderef to run
1126 # goto The new state to move to. Stay in this state if
1128 # continue Goto the new state and run the new state for the
1135 my $ver_num = $version->version;
1136 if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
1137 my $ver_min = $DEFAULT_TAP_VERSION + 1;
1139 "Explicit TAP version must be at least "
1140 . "$ver_min. Got version $ver_num" );
1141 $ver_num = $DEFAULT_TAP_VERSION;
1143 if ( $ver_num > $MAX_TAP_VERSION ) {
1145 "TAP specified version $ver_num but "
1146 . "we don't know about versions later "
1147 . "than $MAX_TAP_VERSION" );
1148 $ver_num = $MAX_TAP_VERSION;
1150 $self->version($ver_num);
1151 $self->_grammar->set_version($ver_num);
1155 plan => { goto => 'PLANNED' },
1156 test => { goto => 'UNPLANNED' },
1159 plan => { goto => 'PLANNED' },
1160 test => { goto => 'UNPLANNED' },
1163 test => { goto => 'PLANNED_AFTER_TEST' },
1168 'More than one plan found in TAP output');
1172 PLANNED_AFTER_TEST => {
1173 test => { goto => 'PLANNED_AFTER_TEST' },
1174 plan => { act => sub { }, continue => 'PLANNED' },
1175 yaml => { goto => 'PLANNED' },
1181 my $line = $self->plan;
1183 "Plan ($line) must be at the beginning "
1184 . "or end of the TAP output" );
1185 $self->is_good_plan(0);
1187 continue => 'PLANNED'
1189 plan => { continue => 'PLANNED' },
1192 test => { goto => 'UNPLANNED_AFTER_TEST' },
1193 plan => { goto => 'GOT_PLAN' },
1195 UNPLANNED_AFTER_TEST => {
1196 test => { act => sub { }, continue => 'UNPLANNED' },
1197 plan => { act => sub { }, continue => 'UNPLANNED' },
1198 yaml => { goto => 'PLANNED' },
1202 # Apply globals and defaults to state table
1203 for my $name ( keys %states ) {
1205 # Merge with globals
1206 my $st = { %state_globals, %{ $states{$name} } };
1209 for my $next ( sort keys %{$st} ) {
1210 if ( my $default = $state_defaults{$next} ) {
1211 for my $def ( sort keys %{$default} ) {
1212 $st->{$next}->{$def} ||= $default->{$def};
1217 # Stuff back in table
1218 $states{$name} = $st;
1224 =head3 C<get_select_handles>
1226 Get an a list of file handles which can be passed to C<select> to
1227 determine the readiness of this parser.
1231 sub get_select_handles { shift->_stream->get_select_handles }
1235 my $stream = $self->_stream;
1236 my $spool = $self->_spool;
1237 my $grammar = $self->_grammar;
1239 my $state_table = $self->_make_state_table;
1241 # Make next_state closure
1242 my $next_state = sub {
1244 my $type = $token->type;
1246 my $state_spec = $state_table->{$state}
1247 or die "Illegal state: $state";
1249 if ( my $next = $state_spec->{$type} ) {
1250 if ( my $act = $next->{act} ) {
1253 if ( my $cont = $next->{continue} ) {
1257 elsif ( my $goto = $next->{goto} ) {
1262 confess("Unhandled token type: $type\n");
1268 # Handle end of stream - which means either pop a block or finish
1269 my $end_handler = sub {
1270 $self->exit( $stream->exit );
1271 $self->wait( $stream->wait );
1276 # Finally make the closure that we return. For performance reasons
1277 # there are two versions of the returned function: one that handles
1278 # callbacks and one that does not.
1279 if ( $self->_has_callbacks ) {
1281 my $result = eval { $grammar->tokenize };
1282 $self->_add_error($@) if $@;
1284 if ( defined $result ) {
1285 $result = $next_state->($result);
1287 if ( my $code = $self->_callback_for( $result->type ) ) {
1288 $_->($result) for @{$code};
1291 $self->_make_callback( 'ELSE', $result );
1294 $self->_make_callback( 'ALL', $result );
1296 # Echo TAP to spool file
1297 print {$spool} $result->raw, "\n" if $spool;
1300 $result = $end_handler->();
1301 $self->_make_callback( 'EOF', $result )
1302 unless defined $result;
1310 my $result = eval { $grammar->tokenize };
1311 $self->_add_error($@) if $@;
1313 if ( defined $result ) {
1314 $result = $next_state->($result);
1316 # Echo TAP to spool file
1317 print {$spool} $result->raw, "\n" if $spool;
1320 $result = $end_handler->();
1331 $self->end_time( $self->get_time );
1334 if ( !$self->plan ) {
1335 $self->_add_error('No plan found in TAP output');
1338 $self->is_good_plan(1) unless defined $self->is_good_plan;
1340 if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
1341 $self->is_good_plan(0);
1342 if ( defined( my $planned = $self->tests_planned ) ) {
1343 my $ran = $self->tests_run;
1345 "Bad plan. You planned $planned tests but ran $ran.");
1348 if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
1350 # this should never happen
1351 my $actual = $self->tests_run;
1352 my $passed = $self->passed;
1353 my $failed = $self->failed;
1354 $self->_croak( "Panic: planned test count ($actual) did not equal "
1355 . "sum of passed ($passed) and failed ($failed) tests!" );
1358 $self->is_good_plan(0) unless defined $self->is_good_plan;
1362 =head3 C<delete_spool>
1364 Delete and return the spool.
1366 my $fh = $parser->delete_spool;
1373 return delete $self->{_spool};
1376 ##############################################################################
1380 As mentioned earlier, a "callback" key may be added to the
1381 C<TAP::Parser> constructor. If present, each callback corresponding to a
1382 given result type will be called with the result as the argument if the
1383 C<run> method is used. The callback is expected to be a subroutine
1384 reference (or anonymous subroutine) which is invoked with the parser
1385 result as its argument.
1388 test => \&test_callback,
1389 plan => \&plan_callback,
1390 comment => \&comment_callback,
1391 bailout => \&bailout_callback,
1392 unknown => \&unknown_callback,
1395 my $aggregator = TAP::Parser::Aggregator->new;
1396 foreach my $file ( @test_files ) {
1397 my $parser = TAP::Parser->new(
1400 callbacks => \%callbacks,
1404 $aggregator->add( $file, $parser );
1407 Callbacks may also be added like this:
1409 $parser->callback( test => \&test_callback );
1410 $parser->callback( plan => \&plan_callback );
1412 The following keys allowed for callbacks. These keys are case-sensitive.
1418 Invoked if C<< $result->is_test >> returns true.
1422 Invoked if C<< $result->is_version >> returns true.
1426 Invoked if C<< $result->is_plan >> returns true.
1430 Invoked if C<< $result->is_comment >> returns true.
1434 Invoked if C<< $result->is_unknown >> returns true.
1438 Invoked if C<< $result->is_yaml >> returns true.
1442 Invoked if C<< $result->is_unknown >> returns true.
1446 If a result does not have a callback defined for it, this callback will
1447 be invoked. Thus, if all of the previous result types are specified as
1448 callbacks, this callback will I<never> be invoked.
1452 This callback will always be invoked and this will happen for each
1453 result after one of the above callbacks is invoked. For example, if
1454 L<Term::ANSIColor> is loaded, you could use the following to color your
1460 if ( $test->is_ok && not $test->directive ) {
1461 # normal passing test
1462 print color 'green';
1464 elsif ( !$test->is_ok ) { # even if it's TODO
1465 print color 'white on_red';
1467 elsif ( $test->has_skip ) {
1468 print color 'white on_blue';
1471 elsif ( $test->has_todo ) {
1472 print color 'white';
1476 # plan, comment, and so on (anything which isn't a test line)
1477 print color 'black on_white';
1481 print shift->as_string;
1482 print color 'reset';
1489 Invoked when there are no more lines to be parsed. Since there is no
1490 accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
1497 If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
1499 =head1 BACKWARDS COMPATABILITY
1501 The Perl-QA list attempted to ensure backwards compatability with
1502 L<Test::Harness>. However, there are some minor differences.
1510 A little-known feature of L<Test::Harness> is that it supported TODO
1514 ok 1 - We have liftoff
1515 not ok 2 - Anti-gravity device activated
1517 Under L<Test::Harness>, test number 2 would I<pass> because it was
1518 listed as a TODO test on the plan line. However, we are not aware of
1519 anyone actually using this feature and hard-coding test numbers is
1520 discouraged because it's very easy to add a test and break the test
1521 number sequence. This makes test suites very fragile. Instead, the
1522 following should be used:
1525 ok 1 - We have liftoff
1526 not ok 2 - Anti-gravity device activated # TODO
1528 =item * 'Missing' tests
1530 It rarely happens, but sometimes a harness might encounter
1539 L<Test::Harness> would report tests 3-14 as having failed. For the
1540 C<TAP::Parser>, these tests are not considered failed because they've
1541 never run. They're reported as parse failures (tests out of sequence).
1545 =head1 ACKNOWLEDGEMENTS
1547 All of the following have helped. Bug reports, patches, (im)moral
1548 support, or just words of encouragement have all been forthcoming.
1552 =item * Michael Schwern
1562 =item * Torsten Schoenfeld
1568 =item * Adam Kennedy
1572 =item * Adrian Howard
1576 =item * Andreas J. Koenig
1578 =item * Florian Ragwitz
1582 =item * Mark Stosberg
1590 Curtis "Ovid" Poe <ovid@cpan.org>
1592 Andy Armstong <andy@hexten.net>
1594 Eric Wilhelm @ <ewilhelm at cpan dot org>
1596 Michael Peters <mpeters at plusthree dot com>
1598 Leif Eriksen <leif dot eriksen at bigpond dot com>
1602 Please report any bugs or feature requests to
1603 C<bug-tapx-parser@rt.cpan.org>, or through the web interface at
1604 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
1605 We will be notified, and then you'll automatically be notified of
1606 progress on your bug as we make changes.
1608 Obviously, bugs which include patches are best. If you prefer, you can
1609 patch against bleed by via anonymous checkout of the latest version:
1611 svn checkout http://svn.hexten.net/tapx
1613 =head1 COPYRIGHT & LICENSE
1615 Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
1617 This program is free software; you can redistribute it and/or modify it
1618 under the same terms as Perl itself.