From 12679ab7d3c2a210f4123163671b532b8b55d5f9 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Fri, 15 Mar 2024 03:06:35 +0000 Subject: CTAN sync 202403150306 --- .../tlnet/tlpkg/tlperl/site/lib/TAP/Parser.pm | 1931 ++++++++++++++++++++ 1 file changed, 1931 insertions(+) create mode 100755 systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser.pm (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser.pm') diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser.pm new file mode 100755 index 0000000000..9283ac3d2f --- /dev/null +++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/TAP/Parser.pm @@ -0,0 +1,1931 @@ +package TAP::Parser; + +use strict; +use warnings; + +use TAP::Parser::Grammar (); +use TAP::Parser::Result (); +use TAP::Parser::ResultFactory (); +use TAP::Parser::Source (); +use TAP::Parser::Iterator (); +use TAP::Parser::IteratorFactory (); +use TAP::Parser::SourceHandler::Executable (); +use TAP::Parser::SourceHandler::Perl (); +use TAP::Parser::SourceHandler::File (); +use TAP::Parser::SourceHandler::RawTAP (); +use TAP::Parser::SourceHandler::Handle (); + +use Carp qw( confess ); + +use base 'TAP::Base'; + +=encoding utf8 + +=head1 NAME + +TAP::Parser - Parse L output + +=head1 VERSION + +Version 3.48 + +=cut + +our $VERSION = '3.48'; + +my $DEFAULT_TAP_VERSION = 12; +my $MAX_TAP_VERSION = 14; + +$ENV{TAP_VERSION} = $MAX_TAP_VERSION; + +END { + + # For VMS. + delete $ENV{TAP_VERSION}; +} + +BEGIN { # making accessors + __PACKAGE__->mk_methods( + qw( + _iterator + _spool + exec + exit + is_good_plan + plan + tests_planned + tests_run + wait + version + in_todo + start_time + end_time + start_times + end_times + skip_all + grammar_class + result_factory_class + iterator_factory_class + ) + ); + + sub _stream { # deprecated + my $self = shift; + $self->_iterator(@_); + } +} # done making accessors + +=head1 SYNOPSIS + + use TAP::Parser; + + my $parser = TAP::Parser->new( { source => $source } ); + + while ( my $result = $parser->next ) { + print $result->as_string; + } + +=head1 DESCRIPTION + +C is designed to produce a proper parse of TAP output. For +an example of how to run tests through this module, see the simple +harnesses C. + +There's a wiki dedicated to the Test Anything Protocol: + +L + +It includes the TAP::Parser Cookbook: + +L + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $parser = TAP::Parser->new(\%args); + +Returns a new C object. + +The arguments should be a hashref with I of the following keys: + +=over 4 + +=item * C + +I + +This is the preferred method of passing input to the constructor. + +The C is used to create a L that is passed to the +L which in turn figures out how to handle the source and +creates a for it. The iterator is used by the parser to +read in the TAP stream. + +To configure the I use the C parameter below. + +Note that C, C and C are I. + +=item * C + +I + +The value should be the complete TAP output. + +The I is used to create a L that is passed to the +L which in turn figures out how to handle the source and +creates a for it. The iterator is used by the parser to +read in the TAP stream. + +To configure the I use the C parameter below. + +Note that C, C and C are I. + +=item * C + +Must be passed an array reference. + +The I array ref is used to create a L that is passed +to the L which in turn figures out how to handle the +source and creates a for it. The iterator is used by +the parser to read in the TAP stream. + +By default the L class will create a +L object to handle the source. This passes the +array reference strings as command arguments to L: + + exec => [ '/usr/bin/ruby', 't/my_test.rb' ] + +If any C are given they will be appended to the end of the command +argument list. + +To configure the I use the C parameter below. + +Note that C, C and C are I. + +=back + +The following keys are optional. + +=over 4 + +=item * C + +I. + +If set, C must be a hashref containing the names of the +Ls to load and/or configure. The values are a +hash of configuration that will be accessible to the source handlers via +L. + +For example: + + sources => { + Perl => { exec => '/path/to/custom/perl' }, + File => { extensions => [ '.tap', '.txt' ] }, + MyCustom => { some => 'config' }, + } + +This will cause C to pass custom configuration to two of the built- +in source handlers - L, +L - and attempt to load the C +class. See L for more detail. + +The C parameter affects how C, C and C parameters +are handled. + +See L, L and subclasses for +more details. + +=item * C + +If present, each callback corresponding to a given result type will be called +with the result as the argument if the C method is used: + + my %callbacks = ( + test => \&test_callback, + plan => \&plan_callback, + comment => \&comment_callback, + bailout => \&bailout_callback, + unknown => \&unknown_callback, + ); + + my $aggregator = TAP::Parser::Aggregator->new; + for my $file ( @test_files ) { + my $parser = TAP::Parser->new( + { + source => $file, + callbacks => \%callbacks, + } + ); + $parser->run; + $aggregator->add( $file, $parser ); + } + +=item * C + +If using a Perl file as a source, optional switches may be passed which will +be used when invoking the perl executable. + + my $parser = TAP::Parser->new( { + source => $test_file, + switches => [ '-Ilib' ], + } ); + +=item * C + +Used in conjunction with the C and C option to supply a reference +to an C<@ARGV> style array of arguments to pass to the test program. + +=item * C + +If passed a filehandle will write a copy of all parsed TAP to that handle. + +=item * C + +If false, STDERR is not captured (though it is 'relayed' to keep it +somewhat synchronized with STDOUT.) + +If true, STDERR and STDOUT are the same filehandle. This may cause +breakage if STDERR contains anything resembling TAP format, but does +allow exact synchronization. + +Subtleties of this behavior may be platform-dependent and may change in +the future. + +=item * C + +This option was introduced to let you easily customize which I class +the parser should use. It defaults to L. + +See also L. + +=item * C + +This option was introduced to let you easily customize which I +factory class the parser should use. It defaults to +L. + +See also L. + +=item * C + +I + +This option was introduced to let you easily customize which I +factory class the parser should use. It defaults to +L. + +=back + +=cut + +# new() implementation supplied by TAP::Base + +# This should make overriding behaviour of the Parser in subclasses easier: +sub _default_grammar_class {'TAP::Parser::Grammar'} +sub _default_result_factory_class {'TAP::Parser::ResultFactory'} +sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + my $parser = TAP::Parser->new( { source => $file } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +This method returns the results of the parsing, one result at a time. Note +that it is destructive. You can't rewind and examine previous results. + +If callbacks are used, they will be issued before this call returns. + +Each result returned is a subclass of L. See that +module and related classes for more information on how to use them. + +=cut + +sub next { + my $self = shift; + return ( $self->{_iter} ||= $self->_iter )->(); +} + +############################################################################## + +=head3 C + + $parser->run; + +This method merely runs the parser and parses all of the TAP. + +=cut + +sub run { + my $self = shift; + while ( defined( my $result = $self->next ) ) { + + # do nothing + } +} + +############################################################################## + +=head3 C + +Make a new L object and return it. Passes through any +arguments given. + +The C can be customized, as described in L. + +=head3 C + +Make a new L object using the parser's +L, and return it. Passes through any arguments +given. + +The C can be customized, as described in L. + +=head3 C + +I. + +Make a new L object and return it. Passes through +any arguments given. + +C can be customized, as described in L. + +=cut + +# This should make overriding behaviour of the Parser in subclasses easier: +sub make_iterator_factory { shift->iterator_factory_class->new(@_); } +sub make_grammar { shift->grammar_class->new(@_); } +sub make_result { shift->result_factory_class->make_result(@_); } + +{ + + # of the following, anything beginning with an underscore is strictly + # internal and should not be exposed. + my %initialize = ( + version => $DEFAULT_TAP_VERSION, + plan => '', # the test plan (e.g., 1..3) + tests_run => 0, # actual current test numbers + skipped => [], # + todo => [], # + passed => [], # + failed => [], # + actual_failed => [], # how many tests really failed + actual_passed => [], # how many tests really passed + todo_passed => [], # tests which unexpectedly succeed + parse_errors => [], # perfect TAP should have none + ); + + # We seem to have this list hanging around all over the place. We could + # probably get it from somewhere else to avoid the repetition. + my @legal_callback = qw( + test + version + plan + comment + bailout + unknown + yaml + ALL + ELSE + EOF + ); + + my @class_overrides = qw( + grammar_class + result_factory_class + iterator_factory_class + ); + + sub _initialize { + my ( $self, $arg_for ) = @_; + + # everything here is basically designed to convert any TAP source to a + # TAP::Parser::Iterator. + + # Shallow copy + my %args = %{ $arg_for || {} }; + + $self->SUPER::_initialize( \%args, \@legal_callback ); + + # get any class overrides out first: + for my $key (@class_overrides) { + my $default_method = "_default_$key"; + my $val = delete $args{$key} || $self->$default_method(); + $self->$key($val); + } + + my $iterator = delete $args{iterator}; + $iterator ||= delete $args{stream}; # deprecated + my $tap = delete $args{tap}; + my $version = delete $args{version}; + my $raw_source = delete $args{source}; + my $sources = delete $args{sources}; + my $exec = delete $args{exec}; + my $merge = delete $args{merge}; + my $spool = delete $args{spool}; + my $switches = delete $args{switches}; + my $ignore_exit = delete $args{ignore_exit}; + my $test_args = delete $args{test_args} || []; + + if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) { + $self->_croak( + "You may only choose one of 'exec', 'tap', 'source' or 'iterator'" + ); + } + + if ( my @excess = sort keys %args ) { + $self->_croak("Unknown options: @excess"); + } + + # convert $tap & $exec to $raw_source equiv. + my $type = ''; + my $source = TAP::Parser::Source->new; + if ($tap) { + $type = 'raw TAP'; + $source->raw( \$tap ); + } + elsif ($exec) { + $type = 'exec ' . $exec->[0]; + $source->raw( { exec => $exec } ); + } + elsif ($raw_source) { + $type = 'source ' . ref($raw_source) || $raw_source; + $source->raw( ref($raw_source) ? $raw_source : \$raw_source ); + } + elsif ($iterator) { + $type = 'iterator ' . ref($iterator); + } + + if ( $source->raw ) { + my $src_factory = $self->make_iterator_factory($sources); + $source->merge($merge)->switches($switches) + ->test_args($test_args); + $iterator = $src_factory->make_iterator($source); + } + + unless ($iterator) { + $self->_croak( + "PANIC: could not determine iterator for input $type"); + } + + while ( my ( $k, $v ) = each %initialize ) { + $self->{$k} = 'ARRAY' eq ref $v ? [] : $v; + } + + $self->version($version) if $version; + $self->_iterator($iterator); + $self->_spool($spool); + $self->ignore_exit($ignore_exit); + + return $self; + } +} + +=head1 INDIVIDUAL RESULTS + +If you've read this far in the docs, you've seen this: + + while ( my $result = $parser->next ) { + print $result->as_string; + } + +Each result returned is a L subclass, referred to as +I. + +=head2 Result types + +Basically, you fetch individual results from the TAP. The six types, with +examples of each, are as follows: + +=over 4 + +=item * Version + + TAP version 12 + +=item * Plan + + 1..42 + +=item * Pragma + + pragma +strict + +=item * Test + + ok 3 - We should start with some foobar! + +=item * Comment + + # Hope we don't use up the foobar. + +=item * Bailout + + Bail out! We ran out of foobar! + +=item * Unknown + + ... yo, this ain't TAP! ... + +=back + +Each result fetched is a result object of a different type. There are common +methods to each result object and different types may have methods unique to +their type. Sometimes a type method may be overridden in a subclass, but its +use is guaranteed to be identical. + +=head2 Common type methods + +=head3 C + +Returns the type of result, such as C or C. + +=head3 C + +Prints a string representation of the token. This might not be the exact +output, however. Tests will have test numbers added if not present, TODO and +SKIP directives will be capitalized and, in general, things will be cleaned +up. If you need the original text for the token, see the C method. + +=head3 C + +Returns the original line of text which was parsed. + +=head3 C + +Indicates whether or not this is the test plan line. + +=head3 C + +Indicates whether or not this is a test line. + +=head3 C + +Indicates whether or not this is a comment. Comments will generally only +appear in the TAP stream if STDERR is merged to STDOUT. See the +C option. + +=head3 C + +Indicates whether or not this is bailout line. + +=head3 C + +Indicates whether or not the current item is a YAML block. + +=head3 C + +Indicates whether or not the current line could be parsed. + +=head3 C + + if ( $result->is_ok ) { ... } + +Reports whether or not a given result has passed. Anything which is B a +test result returns true. This is merely provided as a convenient shortcut +which allows you to do this: + + my $parser = TAP::Parser->new( { source => $source } ); + while ( my $result = $parser->next ) { + # only print failing results + print $result->as_string unless $result->is_ok; + } + +=head2 C methods + + if ( $result->is_plan ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_plan ) { + print $result->plan; + } + +This is merely a synonym for C. + +=head3 C + + my $directive = $result->directive; + +If a SKIP directive is included with the plan, this method will return it. + + 1..0 # SKIP: why bother? + +=head3 C + + my $explanation = $result->explanation; + +If a SKIP directive was included with the plan, this method will return the +explanation, if any. + +=head2 C methods + + if ( $result->is_pragma ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + +Returns a list of pragmas each of which is a + or - followed by the +pragma name. + +=head2 C methods + + if ( $result->is_comment ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_comment ) { + my $comment = $result->comment; + print "I have something to say: $comment"; + } + +=head2 C methods + + if ( $result->is_bailout ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_bailout ) { + my $explanation = $result->explanation; + print "We bailed out because ($explanation)"; + } + +If, and only if, a token is a bailout token, you can get an "explanation" via +this method. The explanation is the text after the mystical "Bail out!" words +which appear in the tap output. + +=head2 C methods + + if ( $result->is_unknown ) { ... } + +There are no unique methods for unknown results. + +=head2 C methods + + if ( $result->is_test ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + my $ok = $result->ok; + +Returns the literal text of the C or C status. + +=head3 C + + my $test_number = $result->number; + +Returns the number of the test, even if the original TAP output did not supply +that number. + +=head3 C + + my $description = $result->description; + +Returns the description of the test, if any. This is the portion after the +test number but before the directive. + +=head3 C + + my $directive = $result->directive; + +Returns either C or C if either directive was present for a test +line. + +=head3 C + + my $explanation = $result->explanation; + +If a test had either a C or C directive, this method will return +the accompanying explanation, if present. + + not ok 17 - 'Pigs can fly' # TODO not enough acid + +For the above line, the explanation is I. + +=head3 C + + if ( $result->is_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed. Remember +that for TODO tests, the test always passes. + +B this was formerly C. The latter method is deprecated and +will issue a warning. + +=head3 C + + if ( $result->is_actual_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed, regardless +of its TODO status. + +B this was formerly C. The latter method is deprecated +and will issue a warning. + +=head3 C + + if ( $test->is_unplanned ) { ... } + +If a test number is greater than the number of planned tests, this method will +return true. Unplanned tests will I return false for C, +regardless of whether or not the test C (see +L for more information about this). + +=head3 C + + if ( $result->has_skip ) { ... } + +Returns a boolean value indicating whether or not this test had a SKIP +directive. + +=head3 C + + if ( $result->has_todo ) { ... } + +Returns a boolean value indicating whether or not this test had a TODO +directive. + +Note that TODO tests I pass. If you need to know whether or not +they really passed, check the C method. + +=head3 C + + if ( $parser->in_todo ) { ... } + +True while the most recent result was a TODO. Becomes true before the +TODO result is returned and stays true until just before the next non- +TODO test is returned. + +=head1 TOTAL RESULTS + +After parsing the TAP, there are many methods available to let you dig through +the results and determine what is meaningful to you. + +=head2 Individual Results + +These results refer to individual tests which are run. + +=head3 C + + my @passed = $parser->passed; # the test numbers which passed + my $passed = $parser->passed; # the number of tests which passed + +This method lets you know which (or how many) tests passed. If a test failed +but had a TODO directive, it will be counted as a passed test. + +=cut + +sub passed { + return @{ $_[0]->{passed} } + if ref $_[0]->{passed}; + return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed}; +} + +=head3 C + + my @failed = $parser->failed; # the test numbers which failed + my $failed = $parser->failed; # the number of tests which failed + +This method lets you know which (or how many) tests failed. If a test passed +but had a TODO directive, it will B be counted as a failed test. + +=cut + +sub failed { @{ shift->{failed} } } + +=head3 C + + # the test numbers which actually passed + my @actual_passed = $parser->actual_passed; + + # the number of tests which actually passed + my $actual_passed = $parser->actual_passed; + +This method lets you know which (or how many) tests actually passed, +regardless of whether or not a TODO directive was found. + +=cut + +sub actual_passed { + return @{ $_[0]->{actual_passed} } + if ref $_[0]->{actual_passed}; + return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed}; +} +*actual_ok = \&actual_passed; + +=head3 C + +This method is a synonym for C. + +=head3 C + + # the test numbers which actually failed + my @actual_failed = $parser->actual_failed; + + # the number of tests which actually failed + my $actual_failed = $parser->actual_failed; + +This method lets you know which (or how many) tests actually failed, +regardless of whether or not a TODO directive was found. + +=cut + +sub actual_failed { @{ shift->{actual_failed} } } + +############################################################################## + +=head3 C + + my @todo = $parser->todo; # the test numbers with todo directives + my $todo = $parser->todo; # the number of tests with todo directives + +This method lets you know which (or how many) tests had TODO directives. + +=cut + +sub todo { @{ shift->{todo} } } + +=head3 C + + # the test numbers which unexpectedly succeeded + my @todo_passed = $parser->todo_passed; + + # the number of tests which unexpectedly succeeded + my $todo_passed = $parser->todo_passed; + +This method lets you know which (or how many) tests actually passed but were +declared as "TODO" tests. + +=cut + +sub todo_passed { @{ shift->{todo_passed} } } + +############################################################################## + +=head3 C + + # deprecated in favor of 'todo_passed'. This method was horribly misnamed. + +This was a badly misnamed method. It indicates which TODO tests unexpectedly +succeeded. Will now issue a warning and call C. + +=cut + +sub todo_failed { + warn + '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; + goto &todo_passed; +} + +=head3 C + + my @skipped = $parser->skipped; # the test numbers with SKIP directives + my $skipped = $parser->skipped; # the number of tests with SKIP directives + +This method lets you know which (or how many) tests had SKIP directives. + +=cut + +sub skipped { @{ shift->{skipped} } } + +=head2 Pragmas + +=head3 C + +Get or set a pragma. To get the state of a pragma: + + if ( $p->pragma('strict') ) { + # be strict + } + +To set the state of a pragma: + + $p->pragma('strict', 1); # enable strict mode + +=cut + +sub pragma { + my ( $self, $pragma ) = splice @_, 0, 2; + + return $self->{pragma}->{$pragma} unless @_; + + if ( my $state = shift ) { + $self->{pragma}->{$pragma} = 1; + } + else { + delete $self->{pragma}->{$pragma}; + } + + return; +} + +=head3 C + +Get a list of all the currently enabled pragmas: + + my @pragmas_enabled = $p->pragmas; + +=cut + +sub pragmas { sort keys %{ shift->{pragma} || {} } } + +=head2 Summary Results + +These results are "meta" information about the total results of an individual +test program. + +=head3 C + + my $plan = $parser->plan; + +Returns the test plan, if found. + +=head3 C + +Deprecated. Use C instead. + +=cut + +sub good_plan { + warn 'good_plan() is deprecated. Please use "is_good_plan()"'; + goto &is_good_plan; +} + +############################################################################## + +=head3 C + + if ( $parser->is_good_plan ) { ... } + +Returns a boolean value indicating whether or not the number of tests planned +matches the number of tests run. + +B this was formerly C. The latter method is deprecated and +will issue a warning. + +And since we're on that subject ... + +=head3 C + + print $parser->tests_planned; + +Returns the number of tests planned, according to the plan. For example, a +plan of '1..17' will mean that 17 tests were planned. + +=head3 C + + print $parser->tests_run; + +Returns the number of tests which actually were run. Hopefully this will +match the number of C<< $parser->tests_planned >>. + +=head3 C + +Returns a true value (actually the reason for skipping) if all tests +were skipped. + +=head3 C + +Returns the wall-clock time when the Parser was created. + +=head3 C + +Returns the wall-clock time when the end of TAP input was seen. + +=head3 C + +Returns the CPU times (like L when the Parser was created. + +=head3 C + +Returns the CPU times (like L when the end of TAP +input was seen. + +=head3 C + + if ( $parser->has_problems ) { + ... + } + +This is a 'catch-all' method which returns true if any tests have currently +failed, any TODO tests unexpectedly succeeded, or any parse errors occurred. + +=cut + +sub has_problems { + my $self = shift; + return + $self->failed + || $self->parse_errors + || ( !$self->ignore_exit && ( $self->wait || $self->exit ) ); +} + +=head3 C + + $parser->version; + +Once the parser is done, this will return the version number for the +parsed TAP. Version numbers were introduced with TAP version 13 so if no +version number is found version 12 is assumed. + +=head3 C + + $parser->exit; + +Once the parser is done, this will return the exit status. If the parser ran +an executable, it returns the exit status of the executable. + +=head3 C + + $parser->wait; + +Once the parser is done, this will return the wait status. If the parser ran +an executable, it returns the wait status of the executable. Otherwise, this +merely returns the C status. + +=head2 C + + $parser->ignore_exit(1); + +Tell the parser to ignore the exit status from the test when determining +whether the test passed. Normally tests with non-zero exit status are +considered to have failed even if all individual tests passed. In cases +where it is not possible to control the exit value of the test script +use this option to ignore it. + +=cut + +sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) } + +=head3 C + + my @errors = $parser->parse_errors; # the parser errors + my $errors = $parser->parse_errors; # the number of parser_errors + +Fortunately, all TAP output is perfect. In the event that it is not, this +method will return parser errors. Note that a junk line which the parser does +not recognize is C an error. This allows this parser to handle future +versions of TAP. The following are all TAP errors reported by the parser: + +=over 4 + +=item * Misplaced plan + +The plan (for example, '1..5'), must only come at the beginning or end of the +TAP output. + +=item * No plan + +Gotta have a plan! + +=item * More than one plan + + 1..3 + ok 1 - input file opened + not ok 2 - first line of the input valid # todo some data + ok 3 read the rest of the file + 1..3 + +Right. Very funny. Don't do that. + +=item * Test numbers out of sequence + + 1..3 + ok 1 - input file opened + not ok 2 - first line of the input valid # todo some data + ok 2 read the rest of the file + +That last test line above should have the number '3' instead of '2'. + +Note that it's perfectly acceptable for some lines to have test numbers and +others to not have them. However, when a test number is found, it must be in +sequence. The following is also an error: + + 1..3 + ok 1 - input file opened + not ok - first line of the input valid # todo some data + ok 2 read the rest of the file + +But this is not: + + 1..3 + ok - input file opened + not ok - first line of the input valid # todo some data + ok 3 read the rest of the file + +=back + +=cut + +sub parse_errors { @{ shift->{parse_errors} } } + +sub _add_error { + my ( $self, $error ) = @_; + push @{ $self->{parse_errors} } => $error; + return $self; +} + +sub _make_state_table { + my $self = shift; + my %states; + my %planned_todo = (); + + # These transitions are defaults for all states + my %state_globals = ( + comment => {}, + bailout => {}, + yaml => {}, + version => { + act => sub { + $self->_add_error( + 'If TAP version is present it must be the first line of output' + ); + }, + }, + unknown => { + act => sub { + my $unk = shift; + if ( $self->pragma('strict') ) { + $self->_add_error( + 'Unknown TAP token: "' . $unk->raw . '"' ); + } + }, + }, + pragma => { + act => sub { + my ($pragma) = @_; + for my $pr ( $pragma->pragmas ) { + if ( $pr =~ /^ ([-+])(\w+) $/x ) { + $self->pragma( $2, $1 eq '+' ); + } + } + }, + }, + ); + + # Provides default elements for transitions + my %state_defaults = ( + plan => { + act => sub { + my ($plan) = @_; + $self->tests_planned( $plan->tests_planned ); + $self->plan( $plan->plan ); + if ( $plan->has_skip ) { + $self->skip_all( $plan->explanation + || '(no reason given)' ); + } + + $planned_todo{$_}++ for @{ $plan->todo_list }; + }, + }, + test => { + act => sub { + my ($test) = @_; + + my ( $number, $tests_run ) + = ( $test->number, ++$self->{tests_run} ); + + # Fake TODO state + if ( defined $number && delete $planned_todo{$number} ) { + $test->set_directive('TODO'); + } + + my $has_todo = $test->has_todo; + + $self->in_todo($has_todo); + if ( defined( my $tests_planned = $self->tests_planned ) ) { + if ( $tests_run > $tests_planned ) { + $test->is_unplanned(1); + } + } + + if ( defined $number ) { + if ( $number != $tests_run ) { + my $count = $tests_run; + $self->_add_error( "Tests out of sequence. Found " + . "($number) but expected ($count)" ); + } + } + else { + $test->_number( $number = $tests_run ); + } + + push @{ $self->{todo} } => $number if $has_todo; + push @{ $self->{todo_passed} } => $number + if $test->todo_passed; + push @{ $self->{skipped} } => $number + if $test->has_skip; + + push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } => + $number; + push @{ + $self->{ + $test->is_actual_ok + ? 'actual_passed' + : 'actual_failed' + } + } => $number; + }, + }, + yaml => { act => sub { }, }, + ); + + # Each state contains a hash the keys of which match a token type. For + # each token + # type there may be: + # act A coderef to run + # goto The new state to move to. Stay in this state if + # missing + # continue Goto the new state and run the new state for the + # current token + %states = ( + INIT => { + version => { + act => sub { + my ($version) = @_; + my $ver_num = $version->version; + if ( $ver_num <= $DEFAULT_TAP_VERSION ) { + my $ver_min = $DEFAULT_TAP_VERSION + 1; + $self->_add_error( + "Explicit TAP version must be at least " + . "$ver_min. Got version $ver_num" ); + $ver_num = $DEFAULT_TAP_VERSION; + } + if ( $ver_num > $MAX_TAP_VERSION ) { + $self->_add_error( + "TAP specified version $ver_num but " + . "we don't know about versions later " + . "than $MAX_TAP_VERSION" ); + $ver_num = $MAX_TAP_VERSION; + } + $self->version($ver_num); + $self->_grammar->set_version($ver_num); + }, + goto => 'PLAN' + }, + plan => { goto => 'PLANNED' }, + test => { goto => 'UNPLANNED' }, + }, + PLAN => { + plan => { goto => 'PLANNED' }, + test => { goto => 'UNPLANNED' }, + }, + PLANNED => { + test => { goto => 'PLANNED_AFTER_TEST' }, + plan => { + act => sub { + my ($version) = @_; + $self->_add_error( + 'More than one plan found in TAP output'); + }, + }, + }, + PLANNED_AFTER_TEST => { + test => { goto => 'PLANNED_AFTER_TEST' }, + plan => { act => sub { }, continue => 'PLANNED' }, + yaml => { goto => 'PLANNED' }, + }, + GOT_PLAN => { + test => { + act => sub { + my ($plan) = @_; + my $line = $self->plan; + $self->_add_error( + "Plan ($line) must be at the beginning " + . "or end of the TAP output" ); + $self->is_good_plan(0); + }, + continue => 'PLANNED' + }, + plan => { continue => 'PLANNED' }, + }, + UNPLANNED => { + test => { goto => 'UNPLANNED_AFTER_TEST' }, + plan => { goto => 'GOT_PLAN' }, + }, + UNPLANNED_AFTER_TEST => { + test => { act => sub { }, continue => 'UNPLANNED' }, + plan => { act => sub { }, continue => 'UNPLANNED' }, + yaml => { goto => 'UNPLANNED' }, + }, + ); + + # Apply globals and defaults to state table + for my $name ( keys %states ) { + + # Merge with globals + my $st = { %state_globals, %{ $states{$name} } }; + + # Add defaults + for my $next ( sort keys %{$st} ) { + if ( my $default = $state_defaults{$next} ) { + for my $def ( sort keys %{$default} ) { + $st->{$next}->{$def} ||= $default->{$def}; + } + } + } + + # Stuff back in table + $states{$name} = $st; + } + + return \%states; +} + +=head3 C + +Get an a list of file handles which can be passed to C