"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/TAP/Parser.pm" (10 Mar 2019, 52145 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package TAP::Parser;
    2 
    3 use strict;
    4 use warnings;
    5 
    6 use TAP::Parser::Grammar                   ();
    7 use TAP::Parser::Result                    ();
    8 use TAP::Parser::ResultFactory             ();
    9 use TAP::Parser::Source                    ();
   10 use TAP::Parser::Iterator                  ();
   11 use TAP::Parser::IteratorFactory           ();
   12 use TAP::Parser::SourceHandler::Executable ();
   13 use TAP::Parser::SourceHandler::Perl       ();
   14 use TAP::Parser::SourceHandler::File       ();
   15 use TAP::Parser::SourceHandler::RawTAP     ();
   16 use TAP::Parser::SourceHandler::Handle     ();
   17 
   18 use Carp qw( confess );
   19 
   20 use base 'TAP::Base';
   21 
   22 =encoding utf8
   23 
   24 =head1 NAME
   25 
   26 TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
   27 
   28 =head1 VERSION
   29 
   30 Version 3.42
   31 
   32 =cut
   33 
   34 our $VERSION = '3.42';
   35 
   36 my $DEFAULT_TAP_VERSION = 12;
   37 my $MAX_TAP_VERSION     = 13;
   38 
   39 $ENV{TAP_VERSION} = $MAX_TAP_VERSION;
   40 
   41 END {
   42 
   43     # For VMS.
   44     delete $ENV{TAP_VERSION};
   45 }
   46 
   47 BEGIN {    # making accessors
   48     __PACKAGE__->mk_methods(
   49         qw(
   50           _iterator
   51           _spool
   52           exec
   53           exit
   54           is_good_plan
   55           plan
   56           tests_planned
   57           tests_run
   58           wait
   59           version
   60           in_todo
   61           start_time
   62           end_time
   63           start_times
   64           end_times
   65           skip_all
   66           grammar_class
   67           result_factory_class
   68           iterator_factory_class
   69           )
   70     );
   71 
   72     sub _stream {    # deprecated
   73         my $self = shift;
   74         $self->_iterator(@_);
   75     }
   76 }    # done making accessors
   77 
   78 =head1 SYNOPSIS
   79 
   80     use TAP::Parser;
   81 
   82     my $parser = TAP::Parser->new( { source => $source } );
   83 
   84     while ( my $result = $parser->next ) {
   85         print $result->as_string;
   86     }
   87 
   88 =head1 DESCRIPTION
   89 
   90 C<TAP::Parser> is designed to produce a proper parse of TAP output. For
   91 an example of how to run tests through this module, see the simple
   92 harnesses C<examples/>.
   93 
   94 There's a wiki dedicated to the Test Anything Protocol:
   95 
   96 L<http://testanything.org>
   97 
   98 It includes the TAP::Parser Cookbook:
   99 
  100 L<http://testanything.org/testing-with-tap/perl/tap::parser-cookbook.html>
  101 
  102 =head1 METHODS
  103 
  104 =head2 Class Methods
  105 
  106 =head3 C<new>
  107 
  108  my $parser = TAP::Parser->new(\%args);
  109 
  110 Returns a new C<TAP::Parser> object.
  111 
  112 The arguments should be a hashref with I<one> of the following keys:
  113 
  114 =over 4
  115 
  116 =item * C<source>
  117 
  118 I<CHANGED in 3.18>
  119 
  120 This is the preferred method of passing input to the constructor.
  121 
  122 The C<source> is used to create a L<TAP::Parser::Source> that is passed to the
  123 L</iterator_factory_class> which in turn figures out how to handle the source and
  124 creates a <TAP::Parser::Iterator> for it.  The iterator is used by the parser to
  125 read in the TAP stream.
  126 
  127 To configure the I<IteratorFactory> use the C<sources> parameter below.
  128 
  129 Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
  130 
  131 =item * C<tap>
  132 
  133 I<CHANGED in 3.18>
  134 
  135 The value should be the complete TAP output.
  136 
  137 The I<tap> is used to create a L<TAP::Parser::Source> that is passed to the
  138 L</iterator_factory_class> which in turn figures out how to handle the source and
  139 creates a <TAP::Parser::Iterator> for it.  The iterator is used by the parser to
  140 read in the TAP stream.
  141 
  142 To configure the I<IteratorFactory> use the C<sources> parameter below.
  143 
  144 Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
  145 
  146 =item * C<exec>
  147 
  148 Must be passed an array reference.
  149 
  150 The I<exec> array ref is used to create a L<TAP::Parser::Source> that is passed
  151 to the L</iterator_factory_class> which in turn figures out how to handle the
  152 source and creates a <TAP::Parser::Iterator> for it.  The iterator is used by
  153 the parser to read in the TAP stream.
  154 
  155 By default the L<TAP::Parser::SourceHandler::Executable> class will create a
  156 L<TAP::Parser::Iterator::Process> object to handle the source.  This passes the
  157 array reference strings as command arguments to L<IPC::Open3::open3|IPC::Open3>:
  158 
  159  exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
  160 
  161 If any C<test_args> are given they will be appended to the end of the command
  162 argument list.
  163 
  164 To configure the I<IteratorFactory> use the C<sources> parameter below.
  165 
  166 Note that C<source>, C<tap> and C<exec> are I<mutually exclusive>.
  167 
  168 =back
  169 
  170 The following keys are optional.
  171 
  172 =over 4
  173 
  174 =item * C<sources>
  175 
  176 I<NEW to 3.18>.
  177 
  178 If set, C<sources> must be a hashref containing the names of the
  179 L<TAP::Parser::SourceHandler>s to load and/or configure.  The values are a
  180 hash of configuration that will be accessible to the source handlers via
  181 L<TAP::Parser::Source/config_for>.
  182 
  183 For example:
  184 
  185   sources => {
  186     Perl => { exec => '/path/to/custom/perl' },
  187     File => { extensions => [ '.tap', '.txt' ] },
  188     MyCustom => { some => 'config' },
  189   }
  190 
  191 This will cause C<TAP::Parser> to pass custom configuration to two of the built-
  192 in source handlers - L<TAP::Parser::SourceHandler::Perl>,
  193 L<TAP::Parser::SourceHandler::File> - and attempt to load the C<MyCustom>
  194 class.  See L<TAP::Parser::IteratorFactory/load_handlers> for more detail.
  195 
  196 The C<sources> parameter affects how C<source>, C<tap> and C<exec> parameters
  197 are handled.
  198 
  199 See L<TAP::Parser::IteratorFactory>, L<TAP::Parser::SourceHandler> and subclasses for
  200 more details.
  201 
  202 =item * C<callback>
  203 
  204 If present, each callback corresponding to a given result type will be called
  205 with the result as the argument if the C<run> method is used:
  206 
  207  my %callbacks = (
  208      test    => \&test_callback,
  209      plan    => \&plan_callback,
  210      comment => \&comment_callback,
  211      bailout => \&bailout_callback,
  212      unknown => \&unknown_callback,
  213  );
  214 
  215  my $aggregator = TAP::Parser::Aggregator->new;
  216  for my $file ( @test_files ) {
  217      my $parser = TAP::Parser->new(
  218          {
  219              source    => $file,
  220              callbacks => \%callbacks,
  221          }
  222      );
  223      $parser->run;
  224      $aggregator->add( $file, $parser );
  225  }
  226 
  227 =item * C<switches>
  228 
  229 If using a Perl file as a source, optional switches may be passed which will
  230 be used when invoking the perl executable.
  231 
  232  my $parser = TAP::Parser->new( {
  233      source   => $test_file,
  234      switches => [ '-Ilib' ],
  235  } );
  236 
  237 =item * C<test_args>
  238 
  239 Used in conjunction with the C<source> and C<exec> option to supply a reference
  240 to an C<@ARGV> style array of arguments to pass to the test program.
  241 
  242 =item * C<spool>
  243 
  244 If passed a filehandle will write a copy of all parsed TAP to that handle.
  245 
  246 =item * C<merge>
  247 
  248 If false, STDERR is not captured (though it is 'relayed' to keep it
  249 somewhat synchronized with STDOUT.)
  250 
  251 If true, STDERR and STDOUT are the same filehandle.  This may cause
  252 breakage if STDERR contains anything resembling TAP format, but does
  253 allow exact synchronization.
  254 
  255 Subtleties of this behavior may be platform-dependent and may change in
  256 the future.
  257 
  258 =item * C<grammar_class>
  259 
  260 This option was introduced to let you easily customize which I<grammar> class
  261 the parser should use.  It defaults to L<TAP::Parser::Grammar>.
  262 
  263 See also L</make_grammar>.
  264 
  265 =item * C<result_factory_class>
  266 
  267 This option was introduced to let you easily customize which I<result>
  268 factory class the parser should use.  It defaults to
  269 L<TAP::Parser::ResultFactory>.
  270 
  271 See also L</make_result>.
  272 
  273 =item * C<iterator_factory_class>
  274 
  275 I<CHANGED in 3.18>
  276 
  277 This option was introduced to let you easily customize which I<iterator>
  278 factory class the parser should use.  It defaults to
  279 L<TAP::Parser::IteratorFactory>.
  280 
  281 =back
  282 
  283 =cut
  284 
  285 # new() implementation supplied by TAP::Base
  286 
  287 # This should make overriding behaviour of the Parser in subclasses easier:
  288 sub _default_grammar_class          {'TAP::Parser::Grammar'}
  289 sub _default_result_factory_class   {'TAP::Parser::ResultFactory'}
  290 sub _default_iterator_factory_class {'TAP::Parser::IteratorFactory'}
  291 
  292 ##############################################################################
  293 
  294 =head2 Instance Methods
  295 
  296 =head3 C<next>
  297 
  298   my $parser = TAP::Parser->new( { source => $file } );
  299   while ( my $result = $parser->next ) {
  300       print $result->as_string, "\n";
  301   }
  302 
  303 This method returns the results of the parsing, one result at a time.  Note
  304 that it is destructive.  You can't rewind and examine previous results.
  305 
  306 If callbacks are used, they will be issued before this call returns.
  307 
  308 Each result returned is a subclass of L<TAP::Parser::Result>.  See that
  309 module and related classes for more information on how to use them.
  310 
  311 =cut
  312 
  313 sub next {
  314     my $self = shift;
  315     return ( $self->{_iter} ||= $self->_iter )->();
  316 }
  317 
  318 ##############################################################################
  319 
  320 =head3 C<run>
  321 
  322   $parser->run;
  323 
  324 This method merely runs the parser and parses all of the TAP.
  325 
  326 =cut
  327 
  328 sub run {
  329     my $self = shift;
  330     while ( defined( my $result = $self->next ) ) {
  331 
  332         # do nothing
  333     }
  334 }
  335 
  336 ##############################################################################
  337 
  338 =head3 C<make_grammar>
  339 
  340 Make a new L<TAP::Parser::Grammar> object and return it.  Passes through any
  341 arguments given.
  342 
  343 The C<grammar_class> can be customized, as described in L</new>.
  344 
  345 =head3 C<make_result>
  346 
  347 Make a new L<TAP::Parser::Result> object using the parser's
  348 L<TAP::Parser::ResultFactory>, and return it.  Passes through any arguments
  349 given.
  350 
  351 The C<result_factory_class> can be customized, as described in L</new>.
  352 
  353 =head3 C<make_iterator_factory>
  354 
  355 I<NEW to 3.18>.
  356 
  357 Make a new L<TAP::Parser::IteratorFactory> object and return it.  Passes through
  358 any arguments given.
  359 
  360 C<iterator_factory_class> can be customized, as described in L</new>.
  361 
  362 =cut
  363 
  364 # This should make overriding behaviour of the Parser in subclasses easier:
  365 sub make_iterator_factory { shift->iterator_factory_class->new(@_); }
  366 sub make_grammar          { shift->grammar_class->new(@_); }
  367 sub make_result           { shift->result_factory_class->make_result(@_); }
  368 
  369 {
  370 
  371     # of the following, anything beginning with an underscore is strictly
  372     # internal and should not be exposed.
  373     my %initialize = (
  374         version       => $DEFAULT_TAP_VERSION,
  375         plan          => '',                    # the test plan (e.g., 1..3)
  376         tests_run     => 0,                     # actual current test numbers
  377         skipped       => [],                    #
  378         todo          => [],                    #
  379         passed        => [],                    #
  380         failed        => [],                    #
  381         actual_failed => [],                    # how many tests really failed
  382         actual_passed => [],                    # how many tests really passed
  383         todo_passed  => [],    # tests which unexpectedly succeed
  384         parse_errors => [],    # perfect TAP should have none
  385     );
  386 
  387     # We seem to have this list hanging around all over the place. We could
  388     # probably get it from somewhere else to avoid the repetition.
  389     my @legal_callback = qw(
  390       test
  391       version
  392       plan
  393       comment
  394       bailout
  395       unknown
  396       yaml
  397       ALL
  398       ELSE
  399       EOF
  400     );
  401 
  402     my @class_overrides = qw(
  403       grammar_class
  404       result_factory_class
  405       iterator_factory_class
  406     );
  407 
  408     sub _initialize {
  409         my ( $self, $arg_for ) = @_;
  410 
  411         # everything here is basically designed to convert any TAP source to a
  412         # TAP::Parser::Iterator.
  413 
  414         # Shallow copy
  415         my %args = %{ $arg_for || {} };
  416 
  417         $self->SUPER::_initialize( \%args, \@legal_callback );
  418 
  419         # get any class overrides out first:
  420         for my $key (@class_overrides) {
  421             my $default_method = "_default_$key";
  422             my $val = delete $args{$key} || $self->$default_method();
  423             $self->$key($val);
  424         }
  425 
  426         my $iterator = delete $args{iterator};
  427         $iterator ||= delete $args{stream};    # deprecated
  428         my $tap         = delete $args{tap};
  429         my $version     = delete $args{version};
  430         my $raw_source  = delete $args{source};
  431         my $sources     = delete $args{sources};
  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} || [];
  438 
  439         if ( 1 < grep {defined} $iterator, $tap, $raw_source, $exec ) {
  440             $self->_croak(
  441                 "You may only choose one of 'exec', 'tap', 'source' or 'iterator'"
  442             );
  443         }
  444 
  445         if ( my @excess = sort keys %args ) {
  446             $self->_croak("Unknown options: @excess");
  447         }
  448 
  449         # convert $tap & $exec to $raw_source equiv.
  450         my $type   = '';
  451         my $source = TAP::Parser::Source->new;
  452         if ($tap) {
  453             $type = 'raw TAP';
  454             $source->raw( \$tap );
  455         }
  456         elsif ($exec) {
  457             $type = 'exec ' . $exec->[0];
  458             $source->raw( { exec => $exec } );
  459         }
  460         elsif ($raw_source) {
  461             $type = 'source ' . ref($raw_source) || $raw_source;
  462             $source->raw( ref($raw_source) ? $raw_source : \$raw_source );
  463         }
  464         elsif ($iterator) {
  465             $type = 'iterator ' . ref($iterator);
  466         }
  467 
  468         if ( $source->raw ) {
  469             my $src_factory = $self->make_iterator_factory($sources);
  470             $source->merge($merge)->switches($switches)
  471               ->test_args($test_args);
  472             $iterator = $src_factory->make_iterator($source);
  473         }
  474 
  475         unless ($iterator) {
  476             $self->_croak(
  477                 "PANIC: could not determine iterator for input $type");
  478         }
  479 
  480         while ( my ( $k, $v ) = each %initialize ) {
  481             $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
  482         }
  483 
  484         $self->version($version) if $version;
  485         $self->_iterator($iterator);
  486         $self->_spool($spool);
  487         $self->ignore_exit($ignore_exit);
  488 
  489         return $self;
  490     }
  491 }
  492 
  493 =head1 INDIVIDUAL RESULTS
  494 
  495 If you've read this far in the docs, you've seen this:
  496 
  497     while ( my $result = $parser->next ) {
  498         print $result->as_string;
  499     }
  500 
  501 Each result returned is a L<TAP::Parser::Result> subclass, referred to as
  502 I<result types>.
  503 
  504 =head2 Result types
  505 
  506 Basically, you fetch individual results from the TAP.  The six types, with
  507 examples of each, are as follows:
  508 
  509 =over 4
  510 
  511 =item * Version
  512 
  513  TAP version 12
  514 
  515 =item * Plan
  516 
  517  1..42
  518 
  519 =item * Pragma
  520 
  521  pragma +strict
  522 
  523 =item * Test
  524 
  525  ok 3 - We should start with some foobar!
  526 
  527 =item * Comment
  528 
  529  # Hope we don't use up the foobar.
  530 
  531 =item * Bailout
  532 
  533  Bail out!  We ran out of foobar!
  534 
  535 =item * Unknown
  536 
  537  ... yo, this ain't TAP! ...
  538 
  539 =back
  540 
  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.
  545 
  546 =head2 Common type methods
  547 
  548 =head3 C<type>
  549 
  550 Returns the type of result, such as C<comment> or C<test>.
  551 
  552 =head3 C<as_string>
  553 
  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.
  558 
  559 =head3  C<raw>
  560 
  561 Returns the original line of text which was parsed.
  562 
  563 =head3 C<is_plan>
  564 
  565 Indicates whether or not this is the test plan line.
  566 
  567 =head3 C<is_test>
  568 
  569 Indicates whether or not this is a test line.
  570 
  571 =head3 C<is_comment>
  572 
  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
  575 C<merge> option.
  576 
  577 =head3 C<is_bailout>
  578 
  579 Indicates whether or not this is bailout line.
  580 
  581 =head3 C<is_yaml>
  582 
  583 Indicates whether or not the current item is a YAML block.
  584 
  585 =head3 C<is_unknown>
  586 
  587 Indicates whether or not the current line could be parsed.
  588 
  589 =head3 C<is_ok>
  590 
  591   if ( $result->is_ok ) { ... }
  592 
  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:
  596 
  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;
  601  }
  602 
  603 =head2 C<plan> methods
  604 
  605  if ( $result->is_plan ) { ... }
  606 
  607 If the above evaluates as true, the following methods will be available on the
  608 C<$result> object.
  609 
  610 =head3 C<plan>
  611 
  612   if ( $result->is_plan ) {
  613      print $result->plan;
  614   }
  615 
  616 This is merely a synonym for C<as_string>.
  617 
  618 =head3 C<directive>
  619 
  620  my $directive = $result->directive;
  621 
  622 If a SKIP directive is included with the plan, this method will return it.
  623 
  624  1..0 # SKIP: why bother?
  625 
  626 =head3 C<explanation>
  627 
  628  my $explanation = $result->explanation;
  629 
  630 If a SKIP directive was included with the plan, this method will return the
  631 explanation, if any.
  632 
  633 =head2 C<pragma> methods
  634 
  635  if ( $result->is_pragma ) { ... }
  636 
  637 If the above evaluates as true, the following methods will be available on the
  638 C<$result> object.
  639 
  640 =head3 C<pragmas>
  641 
  642 Returns a list of pragmas each of which is a + or - followed by the
  643 pragma name.
  644 
  645 =head2 C<comment> methods
  646 
  647  if ( $result->is_comment ) { ... }
  648 
  649 If the above evaluates as true, the following methods will be available on the
  650 C<$result> object.
  651 
  652 =head3 C<comment>
  653 
  654   if ( $result->is_comment ) {
  655       my $comment = $result->comment;
  656       print "I have something to say:  $comment";
  657   }
  658 
  659 =head2 C<bailout> methods
  660 
  661  if ( $result->is_bailout ) { ... }
  662 
  663 If the above evaluates as true, the following methods will be available on the
  664 C<$result> object.
  665 
  666 =head3 C<explanation>
  667 
  668   if ( $result->is_bailout ) {
  669       my $explanation = $result->explanation;
  670       print "We bailed out because ($explanation)";
  671   }
  672 
  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.
  676 
  677 =head2 C<unknown> methods
  678 
  679  if ( $result->is_unknown ) { ... }
  680 
  681 There are no unique methods for unknown results.
  682 
  683 =head2 C<test> methods
  684 
  685  if ( $result->is_test ) { ... }
  686 
  687 If the above evaluates as true, the following methods will be available on the
  688 C<$result> object.
  689 
  690 =head3 C<ok>
  691 
  692   my $ok = $result->ok;
  693 
  694 Returns the literal text of the C<ok> or C<not ok> status.
  695 
  696 =head3 C<number>
  697 
  698   my $test_number = $result->number;
  699 
  700 Returns the number of the test, even if the original TAP output did not supply
  701 that number.
  702 
  703 =head3 C<description>
  704 
  705   my $description = $result->description;
  706 
  707 Returns the description of the test, if any.  This is the portion after the
  708 test number but before the directive.
  709 
  710 =head3 C<directive>
  711 
  712   my $directive = $result->directive;
  713 
  714 Returns either C<TODO> or C<SKIP> if either directive was present for a test
  715 line.
  716 
  717 =head3 C<explanation>
  718 
  719   my $explanation = $result->explanation;
  720 
  721 If a test had either a C<TODO> or C<SKIP> directive, this method will return
  722 the accompanying explanation, if present.
  723 
  724   not ok 17 - 'Pigs can fly' # TODO not enough acid
  725 
  726 For the above line, the explanation is I<not enough acid>.
  727 
  728 =head3 C<is_ok>
  729 
  730   if ( $result->is_ok ) { ... }
  731 
  732 Returns a boolean value indicating whether or not the test passed.  Remember
  733 that for TODO tests, the test always passes.
  734 
  735 B<Note:>  this was formerly C<passed>.  The latter method is deprecated and
  736 will issue a warning.
  737 
  738 =head3 C<is_actual_ok>
  739 
  740   if ( $result->is_actual_ok ) { ... }
  741 
  742 Returns a boolean value indicating whether or not the test passed, regardless
  743 of its TODO status.
  744 
  745 B<Note:>  this was formerly C<actual_passed>.  The latter method is deprecated
  746 and will issue a warning.
  747 
  748 =head3 C<is_unplanned>
  749 
  750   if ( $test->is_unplanned ) { ... }
  751 
  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).
  756 
  757 =head3 C<has_skip>
  758 
  759   if ( $result->has_skip ) { ... }
  760 
  761 Returns a boolean value indicating whether or not this test had a SKIP
  762 directive.
  763 
  764 =head3 C<has_todo>
  765 
  766   if ( $result->has_todo ) { ... }
  767 
  768 Returns a boolean value indicating whether or not this test had a TODO
  769 directive.
  770 
  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.
  773 
  774 =head3 C<in_todo>
  775 
  776   if ( $parser->in_todo ) { ... }
  777 
  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.
  781 
  782 =head1 TOTAL RESULTS
  783 
  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.
  786 
  787 =head2 Individual Results
  788 
  789 These results refer to individual tests which are run.
  790 
  791 =head3 C<passed>
  792 
  793  my @passed = $parser->passed; # the test numbers which passed
  794  my $passed = $parser->passed; # the number of tests which passed
  795 
  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.
  798 
  799 =cut
  800 
  801 sub passed {
  802     return @{ $_[0]->{passed} }
  803       if ref $_[0]->{passed};
  804     return wantarray ? 1 .. $_[0]->{passed} : $_[0]->{passed};
  805 }
  806 
  807 =head3 C<failed>
  808 
  809  my @failed = $parser->failed; # the test numbers which failed
  810  my $failed = $parser->failed; # the number of tests which failed
  811 
  812 This method lets you know which (or how many) tests failed.  If a test passed
  813 but had a TODO directive, it will B<NOT> be counted as a failed test.
  814 
  815 =cut
  816 
  817 sub failed { @{ shift->{failed} } }
  818 
  819 =head3 C<actual_passed>
  820 
  821  # the test numbers which actually passed
  822  my @actual_passed = $parser->actual_passed;
  823 
  824  # the number of tests which actually passed
  825  my $actual_passed = $parser->actual_passed;
  826 
  827 This method lets you know which (or how many) tests actually passed,
  828 regardless of whether or not a TODO directive was found.
  829 
  830 =cut
  831 
  832 sub actual_passed {
  833     return @{ $_[0]->{actual_passed} }
  834       if ref $_[0]->{actual_passed};
  835     return wantarray ? 1 .. $_[0]->{actual_passed} : $_[0]->{actual_passed};
  836 }
  837 *actual_ok = \&actual_passed;
  838 
  839 =head3 C<actual_ok>
  840 
  841 This method is a synonym for C<actual_passed>.
  842 
  843 =head3 C<actual_failed>
  844 
  845  # the test numbers which actually failed
  846  my @actual_failed = $parser->actual_failed;
  847 
  848  # the number of tests which actually failed
  849  my $actual_failed = $parser->actual_failed;
  850 
  851 This method lets you know which (or how many) tests actually failed,
  852 regardless of whether or not a TODO directive was found.
  853 
  854 =cut
  855 
  856 sub actual_failed { @{ shift->{actual_failed} } }
  857 
  858 ##############################################################################
  859 
  860 =head3 C<todo>
  861 
  862  my @todo = $parser->todo; # the test numbers with todo directives
  863  my $todo = $parser->todo; # the number of tests with todo directives
  864 
  865 This method lets you know which (or how many) tests had TODO directives.
  866 
  867 =cut
  868 
  869 sub todo { @{ shift->{todo} } }
  870 
  871 =head3 C<todo_passed>
  872 
  873  # the test numbers which unexpectedly succeeded
  874  my @todo_passed = $parser->todo_passed;
  875 
  876  # the number of tests which unexpectedly succeeded
  877  my $todo_passed = $parser->todo_passed;
  878 
  879 This method lets you know which (or how many) tests actually passed but were
  880 declared as "TODO" tests.
  881 
  882 =cut
  883 
  884 sub todo_passed { @{ shift->{todo_passed} } }
  885 
  886 ##############################################################################
  887 
  888 =head3 C<todo_failed>
  889 
  890   # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
  891 
  892 This was a badly misnamed method.  It indicates which TODO tests unexpectedly
  893 succeeded.  Will now issue a warning and call C<todo_passed>.
  894 
  895 =cut
  896 
  897 sub todo_failed {
  898     warn
  899       '"todo_failed" is deprecated.  Please use "todo_passed".  See the docs.';
  900     goto &todo_passed;
  901 }
  902 
  903 =head3 C<skipped>
  904 
  905  my @skipped = $parser->skipped; # the test numbers with SKIP directives
  906  my $skipped = $parser->skipped; # the number of tests with SKIP directives
  907 
  908 This method lets you know which (or how many) tests had SKIP directives.
  909 
  910 =cut
  911 
  912 sub skipped { @{ shift->{skipped} } }
  913 
  914 =head2 Pragmas
  915 
  916 =head3 C<pragma>
  917 
  918 Get or set a pragma. To get the state of a pragma:
  919 
  920   if ( $p->pragma('strict') ) {
  921       # be strict
  922   }
  923 
  924 To set the state of a pragma:
  925 
  926   $p->pragma('strict', 1); # enable strict mode
  927 
  928 =cut
  929 
  930 sub pragma {
  931     my ( $self, $pragma ) = splice @_, 0, 2;
  932 
  933     return $self->{pragma}->{$pragma} unless @_;
  934 
  935     if ( my $state = shift ) {
  936         $self->{pragma}->{$pragma} = 1;
  937     }
  938     else {
  939         delete $self->{pragma}->{$pragma};
  940     }
  941 
  942     return;
  943 }
  944 
  945 =head3 C<pragmas>
  946 
  947 Get a list of all the currently enabled pragmas:
  948 
  949   my @pragmas_enabled = $p->pragmas;
  950 
  951 =cut
  952 
  953 sub pragmas { sort keys %{ shift->{pragma} || {} } }
  954 
  955 =head2 Summary Results
  956 
  957 These results are "meta" information about the total results of an individual
  958 test program.
  959 
  960 =head3 C<plan>
  961 
  962  my $plan = $parser->plan;
  963 
  964 Returns the test plan, if found.
  965 
  966 =head3 C<good_plan>
  967 
  968 Deprecated.  Use C<is_good_plan> instead.
  969 
  970 =cut
  971 
  972 sub good_plan {
  973     warn 'good_plan() is deprecated.  Please use "is_good_plan()"';
  974     goto &is_good_plan;
  975 }
  976 
  977 ##############################################################################
  978 
  979 =head3 C<is_good_plan>
  980 
  981   if ( $parser->is_good_plan ) { ... }
  982 
  983 Returns a boolean value indicating whether or not the number of tests planned
  984 matches the number of tests run.
  985 
  986 B<Note:>  this was formerly C<good_plan>.  The latter method is deprecated and
  987 will issue a warning.
  988 
  989 And since we're on that subject ...
  990 
  991 =head3 C<tests_planned>
  992 
  993   print $parser->tests_planned;
  994 
  995 Returns the number of tests planned, according to the plan.  For example, a
  996 plan of '1..17' will mean that 17 tests were planned.
  997 
  998 =head3 C<tests_run>
  999 
 1000   print $parser->tests_run;
 1001 
 1002 Returns the number of tests which actually were run.  Hopefully this will
 1003 match the number of C<< $parser->tests_planned >>.
 1004 
 1005 =head3 C<skip_all>
 1006 
 1007 Returns a true value (actually the reason for skipping) if all tests
 1008 were skipped.
 1009 
 1010 =head3 C<start_time>
 1011 
 1012 Returns the wall-clock time when the Parser was created.
 1013 
 1014 =head3 C<end_time>
 1015 
 1016 Returns the wall-clock time when the end of TAP input was seen.
 1017 
 1018 =head3 C<start_times>
 1019 
 1020 Returns the CPU times (like L<perlfunc/times> when the Parser was created.
 1021 
 1022 =head3 C<end_times>
 1023 
 1024 Returns the CPU times (like L<perlfunc/times> when the end of TAP
 1025 input was seen.
 1026 
 1027 =head3 C<has_problems>
 1028 
 1029   if ( $parser->has_problems ) {
 1030       ...
 1031   }
 1032 
 1033 This is a 'catch-all' method which returns true if any tests have currently
 1034 failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
 1035 
 1036 =cut
 1037 
 1038 sub has_problems {
 1039     my $self = shift;
 1040     return
 1041          $self->failed
 1042       || $self->parse_errors
 1043       || ( !$self->ignore_exit && ( $self->wait || $self->exit ) );
 1044 }
 1045 
 1046 =head3 C<version>
 1047 
 1048   $parser->version;
 1049 
 1050 Once the parser is done, this will return the version number for the
 1051 parsed TAP. Version numbers were introduced with TAP version 13 so if no
 1052 version number is found version 12 is assumed.
 1053 
 1054 =head3 C<exit>
 1055 
 1056   $parser->exit;
 1057 
 1058 Once the parser is done, this will return the exit status.  If the parser ran
 1059 an executable, it returns the exit status of the executable.
 1060 
 1061 =head3 C<wait>
 1062 
 1063   $parser->wait;
 1064 
 1065 Once the parser is done, this will return the wait status.  If the parser ran
 1066 an executable, it returns the wait status of the executable.  Otherwise, this
 1067 merely returns the C<exit> status.
 1068 
 1069 =head2 C<ignore_exit>
 1070 
 1071   $parser->ignore_exit(1);
 1072 
 1073 Tell the parser to ignore the exit status from the test when determining
 1074 whether the test passed. Normally tests with non-zero exit status are
 1075 considered to have failed even if all individual tests passed. In cases
 1076 where it is not possible to control the exit value of the test script
 1077 use this option to ignore it.
 1078 
 1079 =cut
 1080 
 1081 sub ignore_exit { shift->pragma( 'ignore_exit', @_ ) }
 1082 
 1083 =head3 C<parse_errors>
 1084 
 1085  my @errors = $parser->parse_errors; # the parser errors
 1086  my $errors = $parser->parse_errors; # the number of parser_errors
 1087 
 1088 Fortunately, all TAP output is perfect.  In the event that it is not, this
 1089 method will return parser errors.  Note that a junk line which the parser does
 1090 not recognize is C<not> an error.  This allows this parser to handle future
 1091 versions of TAP.  The following are all TAP errors reported by the parser:
 1092 
 1093 =over 4
 1094 
 1095 =item * Misplaced plan
 1096 
 1097 The plan (for example, '1..5'), must only come at the beginning or end of the
 1098 TAP output.
 1099 
 1100 =item * No plan
 1101 
 1102 Gotta have a plan!
 1103 
 1104 =item * More than one plan
 1105 
 1106  1..3
 1107  ok 1 - input file opened
 1108  not ok 2 - first line of the input valid # todo some data
 1109  ok 3 read the rest of the file
 1110  1..3
 1111 
 1112 Right.  Very funny.  Don't do that.
 1113 
 1114 =item * Test numbers out of sequence
 1115 
 1116  1..3
 1117  ok 1 - input file opened
 1118  not ok 2 - first line of the input valid # todo some data
 1119  ok 2 read the rest of the file
 1120 
 1121 That last test line above should have the number '3' instead of '2'.
 1122 
 1123 Note that it's perfectly acceptable for some lines to have test numbers and
 1124 others to not have them.  However, when a test number is found, it must be in
 1125 sequence.  The following is also an error:
 1126 
 1127  1..3
 1128  ok 1 - input file opened
 1129  not ok - first line of the input valid # todo some data
 1130  ok 2 read the rest of the file
 1131 
 1132 But this is not:
 1133 
 1134  1..3
 1135  ok  - input file opened
 1136  not ok - first line of the input valid # todo some data
 1137  ok 3 read the rest of the file
 1138 
 1139 =back
 1140 
 1141 =cut
 1142 
 1143 sub parse_errors { @{ shift->{parse_errors} } }
 1144 
 1145 sub _add_error {
 1146     my ( $self, $error ) = @_;
 1147     push @{ $self->{parse_errors} } => $error;
 1148     return $self;
 1149 }
 1150 
 1151 sub _make_state_table {
 1152     my $self = shift;
 1153     my %states;
 1154     my %planned_todo = ();
 1155 
 1156     # These transitions are defaults for all states
 1157     my %state_globals = (
 1158         comment => {},
 1159         bailout => {},
 1160         yaml    => {},
 1161         version => {
 1162             act => sub {
 1163                 $self->_add_error(
 1164                     'If TAP version is present it must be the first line of output'
 1165                 );
 1166             },
 1167         },
 1168         unknown => {
 1169             act => sub {
 1170                 my $unk = shift;
 1171                 if ( $self->pragma('strict') ) {
 1172                     $self->_add_error(
 1173                         'Unknown TAP token: "' . $unk->raw . '"' );
 1174                 }
 1175             },
 1176         },
 1177         pragma => {
 1178             act => sub {
 1179                 my ($pragma) = @_;
 1180                 for my $pr ( $pragma->pragmas ) {
 1181                     if ( $pr =~ /^ ([-+])(\w+) $/x ) {
 1182                         $self->pragma( $2, $1 eq '+' );
 1183                     }
 1184                 }
 1185             },
 1186         },
 1187     );
 1188 
 1189     # Provides default elements for transitions
 1190     my %state_defaults = (
 1191         plan => {
 1192             act => sub {
 1193                 my ($plan) = @_;
 1194                 $self->tests_planned( $plan->tests_planned );
 1195                 $self->plan( $plan->plan );
 1196                 if ( $plan->has_skip ) {
 1197                     $self->skip_all( $plan->explanation
 1198                           || '(no reason given)' );
 1199                 }
 1200 
 1201                 $planned_todo{$_}++ for @{ $plan->todo_list };
 1202             },
 1203         },
 1204         test => {
 1205             act => sub {
 1206                 my ($test) = @_;
 1207 
 1208                 my ( $number, $tests_run )
 1209                   = ( $test->number, ++$self->{tests_run} );
 1210 
 1211                 # Fake TODO state
 1212                 if ( defined $number && delete $planned_todo{$number} ) {
 1213                     $test->set_directive('TODO');
 1214                 }
 1215 
 1216                 my $has_todo = $test->has_todo;
 1217 
 1218                 $self->in_todo($has_todo);
 1219                 if ( defined( my $tests_planned = $self->tests_planned ) ) {
 1220                     if ( $tests_run > $tests_planned ) {
 1221                         $test->is_unplanned(1);
 1222                     }
 1223                 }
 1224 
 1225                 if ( defined $number ) {
 1226                     if ( $number != $tests_run ) {
 1227                         my $count = $tests_run;
 1228                         $self->_add_error( "Tests out of sequence.  Found "
 1229                               . "($number) but expected ($count)" );
 1230                     }
 1231                 }
 1232                 else {
 1233                     $test->_number( $number = $tests_run );
 1234                 }
 1235 
 1236                 push @{ $self->{todo} } => $number if $has_todo;
 1237                 push @{ $self->{todo_passed} } => $number
 1238                   if $test->todo_passed;
 1239                 push @{ $self->{skipped} } => $number
 1240                   if $test->has_skip;
 1241 
 1242                 push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
 1243                   $number;
 1244                 push @{
 1245                     $self->{
 1246                         $test->is_actual_ok
 1247                         ? 'actual_passed'
 1248                         : 'actual_failed'
 1249                       }
 1250                   } => $number;
 1251             },
 1252         },
 1253         yaml => { act => sub { }, },
 1254     );
 1255 
 1256     # Each state contains a hash the keys of which match a token type. For
 1257     # each token
 1258     # type there may be:
 1259     #   act      A coderef to run
 1260     #   goto     The new state to move to. Stay in this state if
 1261     #            missing
 1262     #   continue Goto the new state and run the new state for the
 1263     #            current token
 1264     %states = (
 1265         INIT => {
 1266             version => {
 1267                 act => sub {
 1268                     my ($version) = @_;
 1269                     my $ver_num = $version->version;
 1270                     if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
 1271                         my $ver_min = $DEFAULT_TAP_VERSION + 1;
 1272                         $self->_add_error(
 1273                                 "Explicit TAP version must be at least "
 1274                               . "$ver_min. Got version $ver_num" );
 1275                         $ver_num = $DEFAULT_TAP_VERSION;
 1276                     }
 1277                     if ( $ver_num > $MAX_TAP_VERSION ) {
 1278                         $self->_add_error(
 1279                                 "TAP specified version $ver_num but "
 1280                               . "we don't know about versions later "
 1281                               . "than $MAX_TAP_VERSION" );
 1282                         $ver_num = $MAX_TAP_VERSION;
 1283                     }
 1284                     $self->version($ver_num);
 1285                     $self->_grammar->set_version($ver_num);
 1286                 },
 1287                 goto => 'PLAN'
 1288             },
 1289             plan => { goto => 'PLANNED' },
 1290             test => { goto => 'UNPLANNED' },
 1291         },
 1292         PLAN => {
 1293             plan => { goto => 'PLANNED' },
 1294             test => { goto => 'UNPLANNED' },
 1295         },
 1296         PLANNED => {
 1297             test => { goto => 'PLANNED_AFTER_TEST' },
 1298             plan => {
 1299                 act => sub {
 1300                     my ($version) = @_;
 1301                     $self->_add_error(
 1302                         'More than one plan found in TAP output');
 1303                 },
 1304             },
 1305         },
 1306         PLANNED_AFTER_TEST => {
 1307             test => { goto => 'PLANNED_AFTER_TEST' },
 1308             plan => { act  => sub { }, continue => 'PLANNED' },
 1309             yaml => { goto => 'PLANNED' },
 1310         },
 1311         GOT_PLAN => {
 1312             test => {
 1313                 act => sub {
 1314                     my ($plan) = @_;
 1315                     my $line = $self->plan;
 1316                     $self->_add_error(
 1317                             "Plan ($line) must be at the beginning "
 1318                           . "or end of the TAP output" );
 1319                     $self->is_good_plan(0);
 1320                 },
 1321                 continue => 'PLANNED'
 1322             },
 1323             plan => { continue => 'PLANNED' },
 1324         },
 1325         UNPLANNED => {
 1326             test => { goto => 'UNPLANNED_AFTER_TEST' },
 1327             plan => { goto => 'GOT_PLAN' },
 1328         },
 1329         UNPLANNED_AFTER_TEST => {
 1330             test => { act  => sub { }, continue => 'UNPLANNED' },
 1331             plan => { act  => sub { }, continue => 'UNPLANNED' },
 1332             yaml => { goto => 'UNPLANNED' },
 1333         },
 1334     );
 1335 
 1336     # Apply globals and defaults to state table
 1337     for my $name ( keys %states ) {
 1338 
 1339         # Merge with globals
 1340         my $st = { %state_globals, %{ $states{$name} } };
 1341 
 1342         # Add defaults
 1343         for my $next ( sort keys %{$st} ) {
 1344             if ( my $default = $state_defaults{$next} ) {
 1345                 for my $def ( sort keys %{$default} ) {
 1346                     $st->{$next}->{$def} ||= $default->{$def};
 1347                 }
 1348             }
 1349         }
 1350 
 1351         # Stuff back in table
 1352         $states{$name} = $st;
 1353     }
 1354 
 1355     return \%states;
 1356 }
 1357 
 1358 =head3 C<get_select_handles>
 1359 
 1360 Get an a list of file handles which can be passed to C<select> to
 1361 determine the readiness of this parser.
 1362 
 1363 =cut
 1364 
 1365 sub get_select_handles { shift->_iterator->get_select_handles }
 1366 
 1367 sub _grammar {
 1368     my $self = shift;
 1369     return $self->{_grammar} = shift if @_;
 1370 
 1371     return $self->{_grammar} ||= $self->make_grammar(
 1372         {   iterator => $self->_iterator,
 1373             parser   => $self,
 1374             version  => $self->version
 1375         }
 1376     );
 1377 }
 1378 
 1379 sub _iter {
 1380     my $self        = shift;
 1381     my $iterator    = $self->_iterator;
 1382     my $grammar     = $self->_grammar;
 1383     my $spool       = $self->_spool;
 1384     my $state       = 'INIT';
 1385     my $state_table = $self->_make_state_table;
 1386 
 1387     $self->start_time( $self->get_time );
 1388     $self->start_times( $self->get_times );
 1389 
 1390     # Make next_state closure
 1391     my $next_state = sub {
 1392         my $token = shift;
 1393         my $type  = $token->type;
 1394         TRANS: {
 1395             my $state_spec = $state_table->{$state}
 1396               or die "Illegal state: $state";
 1397 
 1398             if ( my $next = $state_spec->{$type} ) {
 1399                 if ( my $act = $next->{act} ) {
 1400                     $act->($token);
 1401                 }
 1402                 if ( my $cont = $next->{continue} ) {
 1403                     $state = $cont;
 1404                     redo TRANS;
 1405                 }
 1406                 elsif ( my $goto = $next->{goto} ) {
 1407                     $state = $goto;
 1408                 }
 1409             }
 1410             else {
 1411                 confess("Unhandled token type: $type\n");
 1412             }
 1413         }
 1414         return $token;
 1415     };
 1416 
 1417     # Handle end of stream - which means either pop a block or finish
 1418     my $end_handler = sub {
 1419         $self->exit( $iterator->exit );
 1420         $self->wait( $iterator->wait );
 1421         $self->_finish;
 1422         return;
 1423     };
 1424 
 1425     # Finally make the closure that we return. For performance reasons
 1426     # there are two versions of the returned function: one that handles
 1427     # callbacks and one that does not.
 1428     if ( $self->_has_callbacks ) {
 1429         return sub {
 1430             my $result = eval { $grammar->tokenize };
 1431             $self->_add_error($@) if $@;
 1432 
 1433             if ( defined $result ) {
 1434                 $result = $next_state->($result);
 1435 
 1436                 if ( my $code = $self->_callback_for( $result->type ) ) {
 1437                     $_->($result) for @{$code};
 1438                 }
 1439                 else {
 1440                     $self->_make_callback( 'ELSE', $result );
 1441                 }
 1442 
 1443                 $self->_make_callback( 'ALL', $result );
 1444 
 1445                 # Echo TAP to spool file
 1446                 print {$spool} $result->raw, "\n" if $spool;
 1447             }
 1448             else {
 1449                 $result = $end_handler->();
 1450                 $self->_make_callback( 'EOF', $self )
 1451                   unless defined $result;
 1452             }
 1453 
 1454             return $result;
 1455         };
 1456     }    # _has_callbacks
 1457     else {
 1458         return sub {
 1459             my $result = eval { $grammar->tokenize };
 1460             $self->_add_error($@) if $@;
 1461 
 1462             if ( defined $result ) {
 1463                 $result = $next_state->($result);
 1464 
 1465                 # Echo TAP to spool file
 1466                 print {$spool} $result->raw, "\n" if $spool;
 1467             }
 1468             else {
 1469                 $result = $end_handler->();
 1470             }
 1471 
 1472             return $result;
 1473         };
 1474     }    # no callbacks
 1475 }
 1476 
 1477 sub _finish {
 1478     my $self = shift;
 1479 
 1480     $self->end_time( $self->get_time );
 1481     $self->end_times( $self->get_times );
 1482 
 1483     # Avoid leaks
 1484     $self->_iterator(undef);
 1485     $self->_grammar(undef);
 1486 
 1487     # If we just delete the iter we won't get a fault if it's recreated.
 1488     # Instead we set it to a sub that returns an infinite
 1489     # stream of undef. This segfaults on 5.5.4, presumably because
 1490     # we're still executing the closure that gets replaced and it hasn't
 1491     # been protected with a refcount.
 1492     $self->{_iter} = sub {return}
 1493       if $] >= 5.006;
 1494 
 1495     # sanity checks
 1496     if ( !$self->plan ) {
 1497         $self->_add_error('No plan found in TAP output');
 1498     }
 1499     else {
 1500         $self->is_good_plan(1) unless defined $self->is_good_plan;
 1501     }
 1502     if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
 1503         $self->is_good_plan(0);
 1504         if ( defined( my $planned = $self->tests_planned ) ) {
 1505             my $ran = $self->tests_run;
 1506             $self->_add_error(
 1507                 "Bad plan.  You planned $planned tests but ran $ran.");
 1508         }
 1509     }
 1510     if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
 1511 
 1512         # this should never happen
 1513         my $actual = $self->tests_run;
 1514         my $passed = $self->passed;
 1515         my $failed = $self->failed;
 1516         $self->_croak( "Panic: planned test count ($actual) did not equal "
 1517               . "sum of passed ($passed) and failed ($failed) tests!" );
 1518     }
 1519 
 1520     $self->is_good_plan(0) unless defined $self->is_good_plan;
 1521 
 1522     unless ( $self->parse_errors ) {
 1523         # Optimise storage where possible
 1524         if ( $self->tests_run == @{$self->{passed}} ) {
 1525             $self->{passed} = $self->tests_run;
 1526         }
 1527         if ( $self->tests_run == @{$self->{actual_passed}} ) {
 1528             $self->{actual_passed} = $self->tests_run;
 1529         }
 1530     }
 1531 
 1532     return $self;
 1533 }
 1534 
 1535 =head3 C<delete_spool>
 1536 
 1537 Delete and return the spool.
 1538 
 1539   my $fh = $parser->delete_spool;
 1540 
 1541 =cut
 1542 
 1543 sub delete_spool {
 1544     my $self = shift;
 1545 
 1546     return delete $self->{_spool};
 1547 }
 1548 
 1549 ##############################################################################
 1550 
 1551 =head1 CALLBACKS
 1552 
 1553 As mentioned earlier, a "callback" key may be added to the
 1554 C<TAP::Parser> constructor. If present, each callback corresponding to a
 1555 given result type will be called with the result as the argument if the
 1556 C<run> method is used. The callback is expected to be a subroutine
 1557 reference (or anonymous subroutine) which is invoked with the parser
 1558 result as its argument.
 1559 
 1560  my %callbacks = (
 1561      test    => \&test_callback,
 1562      plan    => \&plan_callback,
 1563      comment => \&comment_callback,
 1564      bailout => \&bailout_callback,
 1565      unknown => \&unknown_callback,
 1566  );
 1567 
 1568  my $aggregator = TAP::Parser::Aggregator->new;
 1569  for my $file ( @test_files ) {
 1570      my $parser = TAP::Parser->new(
 1571          {
 1572              source    => $file,
 1573              callbacks => \%callbacks,
 1574          }
 1575      );
 1576      $parser->run;
 1577      $aggregator->add( $file, $parser );
 1578  }
 1579 
 1580 Callbacks may also be added like this:
 1581 
 1582  $parser->callback( test => \&test_callback );
 1583  $parser->callback( plan => \&plan_callback );
 1584 
 1585 The following keys allowed for callbacks. These keys are case-sensitive.
 1586 
 1587 =over 4
 1588 
 1589 =item * C<test>
 1590 
 1591 Invoked if C<< $result->is_test >> returns true.
 1592 
 1593 =item * C<version>
 1594 
 1595 Invoked if C<< $result->is_version >> returns true.
 1596 
 1597 =item * C<plan>
 1598 
 1599 Invoked if C<< $result->is_plan >> returns true.
 1600 
 1601 =item * C<comment>
 1602 
 1603 Invoked if C<< $result->is_comment >> returns true.
 1604 
 1605 =item * C<bailout>
 1606 
 1607 Invoked if C<< $result->is_unknown >> returns true.
 1608 
 1609 =item * C<yaml>
 1610 
 1611 Invoked if C<< $result->is_yaml >> returns true.
 1612 
 1613 =item * C<unknown>
 1614 
 1615 Invoked if C<< $result->is_unknown >> returns true.
 1616 
 1617 =item * C<ELSE>
 1618 
 1619 If a result does not have a callback defined for it, this callback will
 1620 be invoked. Thus, if all of the previous result types are specified as
 1621 callbacks, this callback will I<never> be invoked.
 1622 
 1623 =item * C<ALL>
 1624 
 1625 This callback will always be invoked and this will happen for each
 1626 result after one of the above callbacks is invoked.  For example, if
 1627 L<Term::ANSIColor> is loaded, you could use the following to color your
 1628 test output:
 1629 
 1630  my %callbacks = (
 1631      test => sub {
 1632          my $test = shift;
 1633          if ( $test->is_ok && not $test->directive ) {
 1634              # normal passing test
 1635              print color 'green';
 1636          }
 1637          elsif ( !$test->is_ok ) {    # even if it's TODO
 1638              print color 'white on_red';
 1639          }
 1640          elsif ( $test->has_skip ) {
 1641              print color 'white on_blue';
 1642 
 1643          }
 1644          elsif ( $test->has_todo ) {
 1645              print color 'white';
 1646          }
 1647      },
 1648      ELSE => sub {
 1649          # plan, comment, and so on (anything which isn't a test line)
 1650          print color 'black on_white';
 1651      },
 1652      ALL => sub {
 1653          # now print them
 1654          print shift->as_string;
 1655          print color 'reset';
 1656          print "\n";
 1657      },
 1658  );
 1659 
 1660 =item * C<EOF>
 1661 
 1662 Invoked when there are no more lines to be parsed. Since there is no
 1663 accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
 1664 passed instead.
 1665 
 1666 =back
 1667 
 1668 =head1 TAP GRAMMAR
 1669 
 1670 If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
 1671 
 1672 =head1 BACKWARDS COMPATIBILITY
 1673 
 1674 The Perl-QA list attempted to ensure backwards compatibility with
 1675 L<Test::Harness>.  However, there are some minor differences.
 1676 
 1677 =head2 Differences
 1678 
 1679 =over 4
 1680 
 1681 =item * TODO plans
 1682 
 1683 A little-known feature of L<Test::Harness> is that it supported TODO
 1684 lists in the plan:
 1685 
 1686  1..2 todo 2
 1687  ok 1 - We have liftoff
 1688  not ok 2 - Anti-gravity device activated
 1689 
 1690 Under L<Test::Harness>, test number 2 would I<pass> because it was
 1691 listed as a TODO test on the plan line. However, we are not aware of
 1692 anyone actually using this feature and hard-coding test numbers is
 1693 discouraged because it's very easy to add a test and break the test
 1694 number sequence. This makes test suites very fragile. Instead, the
 1695 following should be used:
 1696 
 1697  1..2
 1698  ok 1 - We have liftoff
 1699  not ok 2 - Anti-gravity device activated # TODO
 1700 
 1701 =item * 'Missing' tests
 1702 
 1703 It rarely happens, but sometimes a harness might encounter
 1704 'missing tests:
 1705 
 1706  ok 1
 1707  ok 2
 1708  ok 15
 1709  ok 16
 1710  ok 17
 1711 
 1712 L<Test::Harness> would report tests 3-14 as having failed. For the
 1713 C<TAP::Parser>, these tests are not considered failed because they've
 1714 never run. They're reported as parse failures (tests out of sequence).
 1715 
 1716 =back
 1717 
 1718 =head1 SUBCLASSING
 1719 
 1720 If you find you need to provide custom functionality (as you would have using
 1721 L<Test::Harness::Straps>), you're in luck: C<TAP::Parser> and friends are
 1722 designed to be easily plugged-into and/or subclassed.
 1723 
 1724 Before you start, it's important to know a few things:
 1725 
 1726 =over 2
 1727 
 1728 =item 1
 1729 
 1730 All C<TAP::*> objects inherit from L<TAP::Object>.
 1731 
 1732 =item 2
 1733 
 1734 Many C<TAP::*> classes have a I<SUBCLASSING> section to guide you.
 1735 
 1736 =item 3
 1737 
 1738 Note that C<TAP::Parser> is designed to be the central "maker" - ie: it is
 1739 responsible for creating most new objects in the C<TAP::Parser::*> namespace.
 1740 
 1741 This makes it possible for you to have a single point of configuring what
 1742 subclasses should be used, which means that in many cases you'll find
 1743 you only need to sub-class one of the parser's components.
 1744 
 1745 The exception to this rule are I<SourceHandlers> & I<Iterators>, but those are
 1746 both created with customizable I<IteratorFactory>.
 1747 
 1748 =item 4
 1749 
 1750 By subclassing, you may end up overriding undocumented methods.  That's not
 1751 a bad thing per se, but be forewarned that undocumented methods may change
 1752 without warning from one release to the next - we cannot guarantee backwards
 1753 compatibility.  If any I<documented> method needs changing, it will be
 1754 deprecated first, and changed in a later release.
 1755 
 1756 =back
 1757 
 1758 =head2 Parser Components
 1759 
 1760 =head3 Sources
 1761 
 1762 A TAP parser consumes input from a single I<raw source> of TAP, which could come
 1763 from anywhere (a file, an executable, a database, an IO handle, a URI, etc..).
 1764 The source gets bundled up in a L<TAP::Parser::Source> object which gathers some
 1765 meta data about it.  The parser then uses a L<TAP::Parser::IteratorFactory> to
 1766 determine which L<TAP::Parser::SourceHandler> to use to turn the raw source
 1767 into a stream of TAP by way of L</Iterators>.
 1768 
 1769 If you simply want C<TAP::Parser> to handle a new source of TAP you probably
 1770 don't need to subclass C<TAP::Parser> itself.  Rather, you'll need to create a
 1771 new L<TAP::Parser::SourceHandler> class, and just plug it into the parser using
 1772 the I<sources> param to L</new>.  Before you start writing one, read through
 1773 L<TAP::Parser::IteratorFactory> to get a feel for how the system works first.
 1774 
 1775 If you find you really need to use your own iterator factory you can still do
 1776 so without sub-classing C<TAP::Parser> by setting L</iterator_factory_class>.
 1777 
 1778 If you just need to customize the objects on creation, subclass L<TAP::Parser>
 1779 and override L</make_iterator_factory>.
 1780 
 1781 Note that C<make_source> & C<make_perl_source> have been I<DEPRECATED> and
 1782 are now removed.
 1783 
 1784 =head3 Iterators
 1785 
 1786 A TAP parser uses I<iterators> to loop through the I<stream> of TAP read in
 1787 from the I<source> it was given.  There are a few types of Iterators available
 1788 by default, all sub-classes of L<TAP::Parser::Iterator>.  Choosing which
 1789 iterator to use is the responsibility of the I<iterator factory>, though it
 1790 simply delegates to the I<Source Handler> it uses.
 1791 
 1792 If you're writing your own L<TAP::Parser::SourceHandler>, you may need to
 1793 create your own iterators too.  If so you'll need to subclass
 1794 L<TAP::Parser::Iterator>.
 1795 
 1796 Note that L</make_iterator> has been I<DEPRECATED> and is now removed.
 1797 
 1798 =head3 Results
 1799 
 1800 A TAP parser creates L<TAP::Parser::Result>s as it iterates through the
 1801 input I<stream>.  There are quite a few result types available; choosing
 1802 which class to use is the responsibility of the I<result factory>.
 1803 
 1804 To create your own result types you have two options:
 1805 
 1806 =over 2
 1807 
 1808 =item option 1
 1809 
 1810 Subclass L<TAP::Parser::Result> and register your new result type/class with
 1811 the default L<TAP::Parser::ResultFactory>.
 1812 
 1813 =item option 2
 1814 
 1815 Subclass L<TAP::Parser::ResultFactory> itself and implement your own
 1816 L<TAP::Parser::Result> creation logic.  Then you'll need to customize the
 1817 class used by your parser by setting the C<result_factory_class> parameter.
 1818 See L</new> for more details.
 1819 
 1820 =back
 1821 
 1822 If you need to customize the objects on creation, subclass L<TAP::Parser> and
 1823 override L</make_result>.
 1824 
 1825 =head3 Grammar
 1826 
 1827 L<TAP::Parser::Grammar> is the heart of the parser.  It tokenizes the TAP
 1828 input I<stream> and produces results.  If you need to customize its behaviour
 1829 you should probably familiarize yourself with the source first.  Enough
 1830 lecturing.
 1831 
 1832 Subclass L<TAP::Parser::Grammar> and customize your parser by setting the
 1833 C<grammar_class> parameter.  See L</new> for more details.
 1834 
 1835 If you need to customize the objects on creation, subclass L<TAP::Parser> and
 1836 override L</make_grammar>
 1837 
 1838 =head1 ACKNOWLEDGMENTS
 1839 
 1840 All of the following have helped. Bug reports, patches, (im)moral
 1841 support, or just words of encouragement have all been forthcoming.
 1842 
 1843 =over 4
 1844 
 1845 =item * Michael Schwern
 1846 
 1847 =item * Andy Lester
 1848 
 1849 =item * chromatic
 1850 
 1851 =item * GEOFFR
 1852 
 1853 =item * Shlomi Fish
 1854 
 1855 =item * Torsten Schoenfeld
 1856 
 1857 =item * Jerry Gay
 1858 
 1859 =item * Aristotle
 1860 
 1861 =item * Adam Kennedy
 1862 
 1863 =item * Yves Orton
 1864 
 1865 =item * Adrian Howard
 1866 
 1867 =item * Sean & Lil
 1868 
 1869 =item * Andreas J. Koenig
 1870 
 1871 =item * Florian Ragwitz
 1872 
 1873 =item * Corion
 1874 
 1875 =item * Mark Stosberg
 1876 
 1877 =item * Matt Kraai
 1878 
 1879 =item * David Wheeler
 1880 
 1881 =item * Alex Vandiver
 1882 
 1883 =item * Cosimo Streppone
 1884 
 1885 =item * Ville Skyttä
 1886 
 1887 =back
 1888 
 1889 =head1 AUTHORS
 1890 
 1891 Curtis "Ovid" Poe <ovid@cpan.org>
 1892 
 1893 Andy Armstong <andy@hexten.net>
 1894 
 1895 Eric Wilhelm @ <ewilhelm at cpan dot org>
 1896 
 1897 Michael Peters <mpeters at plusthree dot com>
 1898 
 1899 Leif Eriksen <leif dot eriksen at bigpond dot com>
 1900 
 1901 Steve Purkis <spurkis@cpan.org>
 1902 
 1903 Nicholas Clark <nick@ccl4.org>
 1904 
 1905 Lee Johnson <notfadeaway at btinternet dot com>
 1906 
 1907 Philippe Bruhat <book@cpan.org>
 1908 
 1909 =head1 BUGS
 1910 
 1911 Please report any bugs or feature requests to
 1912 C<bug-test-harness@rt.cpan.org>, or through the web interface at
 1913 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
 1914 We will be notified, and then you'll automatically be notified of
 1915 progress on your bug as we make changes.
 1916 
 1917 Obviously, bugs which include patches are best. If you prefer, you can
 1918 patch against bleed by via anonymous checkout of the latest version:
 1919 
 1920  git clone git://github.com/Perl-Toolchain-Gang/Test-Harness.git
 1921 
 1922 =head1 COPYRIGHT & LICENSE
 1923 
 1924 Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.
 1925 
 1926 This program is free software; you can redistribute it and/or modify it
 1927 under the same terms as Perl itself.
 1928 
 1929 =cut
 1930 
 1931 1;