lib/TAP/Parser.pm

   1 package TAP::Parser;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA);
   5
   6 use TAP::Base                 ();
   7 use TAP::Parser::Grammar      ();
   8 use TAP::Parser::Result       ();
   9 use TAP::Parser::Source       ();
  10 use TAP::Parser::Source::Perl ();
  11 use TAP::Parser::Iterator     ();
  12 use Carp                      ();
  13
  14 @ISA = qw(TAP::Base);
  15
  16 =head1 NAME
  17
  18 TAP::Parser - Parse L<TAP|Test::Harness::TAP> output
  19
  20 =head1 VERSION
  21
  22 Version 3.06
  23
  24 =cut
  25
  26 $VERSION = '3.06';
  27
  28 my $DEFAULT_TAP_VERSION = 12;
  29 my $MAX_TAP_VERSION     = 13;
  30
  31 $ENV{TAP_VERSION} = $MAX_TAP_VERSION;
  32
  33 END {
  34
  35     # For VMS.
  36     delete $ENV{TAP_VERSION};
  37 }
  38
  39 BEGIN {    # making accessors
  40     foreach my $method (
  41         qw(
  42         _stream
  43         _spool
  44         _grammar
  45         exec
  46         exit
  47         is_good_plan
  48         plan
  49         tests_planned
  50         tests_run
  51         wait
  52         version
  53         in_todo
  54         start_time
  55         end_time
  56         skip_all
  57         )
  58       )
  59     {
  60         no strict 'refs';
  61
  62         # another tiny performance hack
  63         if ( $method =~ /^_/ ) {
  64             *$method = sub {
  65                 my $self = shift;
  66                 return $self->{$method} unless @_;
  67
  68                 # Trusted methods
  69                 unless ( ( ref $self ) =~ /^TAP::Parser/ ) {
  70                     Carp::croak("$method() may not be set externally");
  71                 }
  72
  73                 $self->{$method} = shift;
  74             };
  75         }
  76         else {
  77             *$method = sub {
  78                 my $self = shift;
  79                 return $self->{$method} unless @_;
  80                 $self->{$method} = shift;
  81             };
  82         }
  83     }
  84 }    # done making accessors
  85
  86 =head1 SYNOPSIS
  87
  88     use TAP::Parser;
  89
  90     my $parser = TAP::Parser->new( { source => $source } );
  91
  92     while ( my $result = $parser->next ) {
  93         print $result->as_string;
  94     }
  95
  96 =head1 DESCRIPTION
  97
  98 C<TAP::Parser> is designed to produce a proper parse of TAP output. For
  99 an example of how to run tests through this module, see the simple
 100 harnesses C<examples/>.
 101
 102 There's a wiki dedicated to the Test Anything Protocol:
 103
 104 L<http://testanything.org>
 105
 106 It includes the TAP::Parser Cookbook:
 107
 108 L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
 109
 110 =head1 METHODS
 111
 112 =head2 Class Methods
 113
 114 =head3 C<new>
 115
 116  my $parser = TAP::Parser->new(\%args);
 117
 118 Returns a new C<TAP::Parser> object.
 119
 120 The arguments should be a hashref with I<one> of the following keys:
 121
 122 =over 4
 123
 124 =item * C<source>
 125
 126 This is the preferred method of passing arguments to the constructor.  To
 127 determine how to handle the source, the following steps are taken.
 128
 129 If the source contains a newline, it's assumed to be a string of raw TAP
 130 output.
 131
 132 If the source is a reference, it's assumed to be something to pass to
 133 the L<TAP::Parser::Iterator::Stream> constructor. This is used
 134 internally and you should not use it.
 135
 136 Otherwise, the parser does a C<-e> check to see if the source exists.  If so,
 137 it attempts to execute the source and read the output as a stream.  This is by
 138 far the preferred method of using the parser.
 139
 140  foreach my $file ( @test_files ) {
 141      my $parser = TAP::Parser->new( { source => $file } );
 142      # do stuff with the parser
 143  }
 144
 145 =item * C<tap>
 146
 147 The value should be the complete TAP output.
 148
 149 =item * C<exec>
 150
 151 If passed an array reference, will attempt to create the iterator by
 152 passing a L<TAP::Parser::Source> object to
 153 L<TAP::Parser::Iterator::Source>, using the array reference strings as
 154 the command arguments to L<IPC::Open3::open3|IPC::Open3>:
 155
 156  exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
 157
 158 Note that C<source> and C<exec> are mutually exclusive.
 159
 160 =back
 161
 162 The following keys are optional.
 163
 164 =over 4
 165
 166 =item * C<callback>
 167
 168 If present, each callback corresponding to a given result type will be called
 169 with the result as the argument if the C<run> method is used:
 170
 171  my %callbacks = (
 172      test    => \&test_callback,
 173      plan    => \&plan_callback,
 174      comment => \&comment_callback,
 175      bailout => \&bailout_callback,
 176      unknown => \&unknown_callback,
 177  );
 178
 179  my $aggregator = TAP::Parser::Aggregator->new;
 180  foreach my $file ( @test_files ) {
 181      my $parser = TAP::Parser->new(
 182          {
 183              source    => $file,
 184              callbacks => \%callbacks,
 185          }
 186      );
 187      $parser->run;
 188      $aggregator->add( $file, $parser );
 189  }
 190
 191 =item * C<switches>
 192
 193 If using a Perl file as a source, optional switches may be passed which will
 194 be used when invoking the perl executable.
 195
 196  my $parser = TAP::Parser->new( {
 197      source   => $test_file,
 198      switches => '-Ilib',
 199  } );
 200
 201 =item * C<test_args>
 202
 203 Used in conjunction with the C<source> option to supply a reference to
 204 an C<@ARGV> style array of arguments to pass to the test program.
 205
 206 =item * C<spool>
 207
 208 If passed a filehandle will write a copy of all parsed TAP to that handle.
 209
 210 =item * C<merge>
 211
 212 If false, STDERR is not captured (though it is 'relayed' to keep it
 213 somewhat synchronized with STDOUT.)
 214
 215 If true, STDERR and STDOUT are the same filehandle.  This may cause
 216 breakage if STDERR contains anything resembling TAP format, but does
 217 allow exact synchronization.
 218
 219 Subtleties of this behavior may be platform-dependent and may change in
 220 the future.
 221
 222 =back
 223
 224 =cut
 225
 226 # new implementation supplied by TAP::Base
 227
 228 ##############################################################################
 229
 230 =head2 Instance Methods
 231
 232 =head3 C<next>
 233
 234   my $parser = TAP::Parser->new( { source => $file } );
 235   while ( my $result = $parser->next ) {
 236       print $result->as_string, "\n";
 237   }
 238
 239 This method returns the results of the parsing, one result at a time.  Note
 240 that it is destructive.  You can't rewind and examine previous results.
 241
 242 If callbacks are used, they will be issued before this call returns.
 243
 244 Each result returned is a subclass of L<TAP::Parser::Result>.  See that
 245 module and related classes for more information on how to use them.
 246
 247 =cut
 248
 249 sub next {
 250     my $self = shift;
 251     return ( $self->{_iter} ||= $self->_iter )->();
 252 }
 253
 254 ##############################################################################
 255
 256 =head3 C<run>
 257
 258   $parser->run;
 259
 260 This method merely runs the parser and parses all of the TAP.
 261
 262 =cut
 263
 264 sub run {
 265     my $self = shift;
 266     while ( defined( my $result = $self->next ) ) {
 267
 268         # do nothing
 269     }
 270 }
 271
 272 {
 273
 274     # of the following, anything beginning with an underscore is strictly
 275     # internal and should not be exposed.
 276     my %initialize = (
 277         version       => $DEFAULT_TAP_VERSION,
 278         plan          => '',                    # the test plan (e.g., 1..3)
 279         tap           => '',                    # the TAP
 280         tests_run     => 0,                     # actual current test numbers
 281         results       => [],                    # TAP parser results
 282         skipped       => [],                    #
 283         todo          => [],                    #
 284         passed        => [],                    #
 285         failed        => [],                    #
 286         actual_failed => [],                    # how many tests really failed
 287         actual_passed => [],                    # how many tests really passed
 288         todo_passed  => [],    # tests which unexpectedly succeed
 289         parse_errors => [],    # perfect TAP should have none
 290     );
 291
 292     # We seem to have this list hanging around all over the place. We could
 293     # probably get it from somewhere else to avoid the repetition.
 294     my @legal_callback = qw(
 295       test
 296       version
 297       plan
 298       comment
 299       bailout
 300       unknown
 301       yaml
 302       ALL
 303       ELSE
 304       EOF
 305     );
 306
 307     sub _initialize {
 308         my ( $self, $arg_for ) = @_;
 309
 310         # everything here is basically designed to convert any TAP source to a
 311         # stream.
 312
 313         # Shallow copy
 314         my %args = %{ $arg_for || {} };
 315
 316         $self->SUPER::_initialize( \%args, \@legal_callback );
 317
 318         my $stream    = delete $args{stream};
 319         my $tap       = delete $args{tap};
 320         my $source    = delete $args{source};
 321         my $exec      = delete $args{exec};
 322         my $merge     = delete $args{merge};
 323         my $spool     = delete $args{spool};
 324         my $switches  = delete $args{switches};
 325         my @test_args = @{ delete $args{test_args} || [] };
 326
 327         if ( 1 < grep {defined} $stream, $tap, $source, $exec ) {
 328             $self->_croak(
 329                 "You may only choose one of 'exec', 'stream', 'tap' or 'source'"
 330             );
 331         }
 332
 333         if ( my @excess = sort keys %args ) {
 334             $self->_croak("Unknown options: @excess");
 335         }
 336
 337         if ($tap) {
 338             $stream = TAP::Parser::Iterator->new( [ split "\n" => $tap ] );
 339         }
 340         elsif ($exec) {
 341             my $source = TAP::Parser::Source->new;
 342             $source->source( [ @$exec, @test_args ] );
 343             $source->merge($merge);    # XXX should just be arguments?
 344             $stream = $source->get_stream;
 345         }
 346         elsif ($source) {
 347             if ( my $ref = ref $source ) {
 348                 $stream = TAP::Parser::Iterator->new($source);
 349             }
 350             elsif ( -e $source ) {
 351
 352                 my $perl = TAP::Parser::Source::Perl->new;
 353
 354                 $perl->switches($switches)
 355                   if $switches;
 356
 357                 $perl->merge($merge);    # XXX args to new()?
 358
 359                 $perl->source( [ $source, @test_args ] );
 360
 361                 $stream = $perl->get_stream;
 362             }
 363             else {
 364                 $self->_croak("Cannot determine source for $source");
 365             }
 366         }
 367
 368         unless ($stream) {
 369             $self->_croak('PANIC: could not determine stream');
 370         }
 371
 372         while ( my ( $k, $v ) = each %initialize ) {
 373             $self->{$k} = 'ARRAY' eq ref $v ? [] : $v;
 374         }
 375
 376         $self->_stream($stream);
 377         my $grammar = TAP::Parser::Grammar->new($stream);
 378         $grammar->set_version( $self->version );
 379         $self->_grammar($grammar);
 380         $self->_spool($spool);
 381
 382         $self->start_time( $self->get_time );
 383
 384         return $self;
 385     }
 386 }
 387
 388 =head1 INDIVIDUAL RESULTS
 389
 390 If you've read this far in the docs, you've seen this:
 391
 392     while ( my $result = $parser->next ) {
 393         print $result->as_string;
 394     }
 395
 396 Each result returned is a L<TAP::Parser::Result> subclass, referred to as
 397 I<result types>.
 398
 399 =head2 Result types
 400
 401 Basically, you fetch individual results from the TAP.  The six types, with
 402 examples of each, are as follows:
 403
 404 =over 4
 405
 406 =item * Version
 407
 408  TAP version 12
 409
 410 =item * Plan
 411
 412  1..42
 413
 414 =item * Test
 415
 416  ok 3 - We should start with some foobar!
 417
 418 =item * Comment
 419
 420  # Hope we don't use up the foobar.
 421
 422 =item * Bailout
 423
 424  Bail out!  We ran out of foobar!
 425
 426 =item * Unknown
 427
 428  ... yo, this ain't TAP! ...
 429
 430 =back
 431
 432 Each result fetched is a result object of a different type.  There are common
 433 methods to each result object and different types may have methods unique to
 434 their type.  Sometimes a type method may be overridden in a subclass, but its
 435 use is guaranteed to be identical.
 436
 437 =head2 Common type methods
 438
 439 =head3 C<type>
 440
 441 Returns the type of result, such as C<comment> or C<test>.
 442
 443 =head3 C<as_string>
 444
 445 Prints a string representation of the token.  This might not be the exact
 446 output, however.  Tests will have test numbers added if not present, TODO and
 447 SKIP directives will be capitalized and, in general, things will be cleaned
 448 up.  If you need the original text for the token, see the C<raw> method.
 449
 450 =head3  C<raw>
 451
 452 Returns the original line of text which was parsed.
 453
 454 =head3 C<is_plan>
 455
 456 Indicates whether or not this is the test plan line.
 457
 458 =head3 C<is_test>
 459
 460 Indicates whether or not this is a test line.
 461
 462 =head3 C<is_comment>
 463
 464 Indicates whether or not this is a comment. Comments will generally only
 465 appear in the TAP stream if STDERR is merged to STDOUT. See the
 466 C<merge> option.
 467
 468 =head3 C<is_bailout>
 469
 470 Indicates whether or not this is bailout line.
 471
 472 =head3 C<is_yaml>
 473
 474 Indicates whether or not the current item is a YAML block.
 475
 476 =head3 C<is_unknown>
 477
 478 Indicates whether or not the current line could be parsed.
 479
 480 =head3 C<is_ok>
 481
 482   if ( $result->is_ok ) { ... }
 483
 484 Reports whether or not a given result has passed.  Anything which is B<not> a
 485 test result returns true.  This is merely provided as a convenient shortcut
 486 which allows you to do this:
 487
 488  my $parser = TAP::Parser->new( { source => $source } );
 489  while ( my $result = $parser->next ) {
 490      # only print failing results
 491      print $result->as_string unless $result->is_ok;
 492  }
 493
 494 =head2 C<plan> methods
 495
 496  if ( $result->is_plan ) { ... }
 497
 498 If the above evaluates as true, the following methods will be available on the
 499 C<$result> object.
 500
 501 =head3 C<plan>
 502
 503   if ( $result->is_plan ) {
 504      print $result->plan;
 505   }
 506
 507 This is merely a synonym for C<as_string>.
 508
 509 =head3 C<tests_planned>
 510
 511   my $planned = $result->tests_planned;
 512
 513 Returns the number of tests planned.  For example, a plan of C<1..17> will
 514 cause this method to return '17'.
 515
 516 =head3 C<directive>
 517
 518  my $directive = $result->directive;
 519
 520 If a SKIP directive is included with the plan, this method will return it.
 521
 522  1..0 # SKIP: why bother?
 523
 524 =head3 C<explanation>
 525
 526  my $explanation = $result->explanation;
 527
 528 If a SKIP directive was included with the plan, this method will return the
 529 explanation, if any.
 530
 531 =head2 C<commment> methods
 532
 533  if ( $result->is_comment ) { ... }
 534
 535 If the above evaluates as true, the following methods will be available on the
 536 C<$result> object.
 537
 538 =head3 C<comment>
 539
 540   if ( $result->is_comment ) {
 541       my $comment = $result->comment;
 542       print "I have something to say:  $comment";
 543   }
 544
 545 =head2 C<bailout> methods
 546
 547  if ( $result->is_bailout ) { ... }
 548
 549 If the above evaluates as true, the following methods will be available on the
 550 C<$result> object.
 551
 552 =head3 C<explanation>
 553
 554   if ( $result->is_bailout ) {
 555       my $explanation = $result->explanation;
 556       print "We bailed out because ($explanation)";
 557   }
 558
 559 If, and only if, a token is a bailout token, you can get an "explanation" via
 560 this method.  The explanation is the text after the mystical "Bail out!" words
 561 which appear in the tap output.
 562
 563 =head2 C<unknown> methods
 564
 565  if ( $result->is_unknown ) { ... }
 566
 567 There are no unique methods for unknown results.
 568
 569 =head2 C<test> methods
 570
 571  if ( $result->is_test ) { ... }
 572
 573 If the above evaluates as true, the following methods will be available on the
 574 C<$result> object.
 575
 576 =head3 C<ok>
 577
 578   my $ok = $result->ok;
 579
 580 Returns the literal text of the C<ok> or C<not ok> status.
 581
 582 =head3 C<number>
 583
 584   my $test_number = $result->number;
 585
 586 Returns the number of the test, even if the original TAP output did not supply
 587 that number.
 588
 589 =head3 C<description>
 590
 591   my $description = $result->description;
 592
 593 Returns the description of the test, if any.  This is the portion after the
 594 test number but before the directive.
 595
 596 =head3 C<directive>
 597
 598   my $directive = $result->directive;
 599
 600 Returns either C<TODO> or C<SKIP> if either directive was present for a test
 601 line.
 602
 603 =head3 C<explanation>
 604
 605   my $explanation = $result->explanation;
 606
 607 If a test had either a C<TODO> or C<SKIP> directive, this method will return
 608 the accompanying explantion, if present.
 609
 610   not ok 17 - 'Pigs can fly' # TODO not enough acid
 611
 612 For the above line, the explanation is I<not enough acid>.
 613
 614 =head3 C<is_ok>
 615
 616   if ( $result->is_ok ) { ... }
 617
 618 Returns a boolean value indicating whether or not the test passed.  Remember
 619 that for TODO tests, the test always passes.
 620
 621 B<Note:>  this was formerly C<passed>.  The latter method is deprecated and
 622 will issue a warning.
 623
 624 =head3 C<is_actual_ok>
 625
 626   if ( $result->is_actual_ok ) { ... }
 627
 628 Returns a boolean value indicating whether or not the test passed, regardless
 629 of its TODO status.
 630
 631 B<Note:>  this was formerly C<actual_passed>.  The latter method is deprecated
 632 and will issue a warning.
 633
 634 =head3 C<is_unplanned>
 635
 636   if ( $test->is_unplanned ) { ... }
 637
 638 If a test number is greater than the number of planned tests, this method will
 639 return true.  Unplanned tests will I<always> return false for C<is_ok>,
 640 regardless of whether or not the test C<has_todo> (see
 641 L<TAP::Parser::Result::Test> for more information about this).
 642
 643 =head3 C<has_skip>
 644
 645   if ( $result->has_skip ) { ... }
 646
 647 Returns a boolean value indicating whether or not this test had a SKIP
 648 directive.
 649
 650 =head3 C<has_todo>
 651
 652   if ( $result->has_todo ) { ... }
 653
 654 Returns a boolean value indicating whether or not this test had a TODO
 655 directive.
 656
 657 Note that TODO tests I<always> pass.  If you need to know whether or not
 658 they really passed, check the C<is_actual_ok> method.
 659
 660 =head3 C<in_todo>
 661
 662   if ( $parser->in_todo ) { ... }
 663
 664 True while the most recent result was a TODO. Becomes true before the
 665 TODO result is returned and stays true until just before the next non-
 666 TODO test is returned.
 667
 668 =head1 TOTAL RESULTS
 669
 670 After parsing the TAP, there are many methods available to let you dig through
 671 the results and determine what is meaningful to you.
 672
 673 =head2 Individual Results
 674
 675 These results refer to individual tests which are run.
 676
 677 =head3 C<passed>
 678
 679  my @passed = $parser->passed; # the test numbers which passed
 680  my $passed = $parser->passed; # the number of tests which passed
 681
 682 This method lets you know which (or how many) tests passed.  If a test failed
 683 but had a TODO directive, it will be counted as a passed test.
 684
 685 =cut
 686
 687 sub passed { @{ shift->{passed} } }
 688
 689 =head3 C<failed>
 690
 691  my @failed = $parser->failed; # the test numbers which failed
 692  my $failed = $parser->failed; # the number of tests which failed
 693
 694 This method lets you know which (or how many) tests failed.  If a test passed
 695 but had a TODO directive, it will B<NOT> be counted as a failed test.
 696
 697 =cut
 698
 699 sub failed { @{ shift->{failed} } }
 700
 701 =head3 C<actual_passed>
 702
 703  # the test numbers which actually passed
 704  my @actual_passed = $parser->actual_passed;
 705
 706  # the number of tests which actually passed
 707  my $actual_passed = $parser->actual_passed;
 708
 709 This method lets you know which (or how many) tests actually passed,
 710 regardless of whether or not a TODO directive was found.
 711
 712 =cut
 713
 714 sub actual_passed { @{ shift->{actual_passed} } }
 715 *actual_ok = \&actual_passed;
 716
 717 =head3 C<actual_ok>
 718
 719 This method is a synonym for C<actual_passed>.
 720
 721 =head3 C<actual_failed>
 722
 723  # the test numbers which actually failed
 724  my @actual_failed = $parser->actual_failed;
 725
 726  # the number of tests which actually failed
 727  my $actual_failed = $parser->actual_failed;
 728
 729 This method lets you know which (or how many) tests actually failed,
 730 regardless of whether or not a TODO directive was found.
 731
 732 =cut
 733
 734 sub actual_failed { @{ shift->{actual_failed} } }
 735
 736 ##############################################################################
 737
 738 =head3 C<todo>
 739
 740  my @todo = $parser->todo; # the test numbers with todo directives
 741  my $todo = $parser->todo; # the number of tests with todo directives
 742
 743 This method lets you know which (or how many) tests had TODO directives.
 744
 745 =cut
 746
 747 sub todo { @{ shift->{todo} } }
 748
 749 =head3 C<todo_passed>
 750
 751  # the test numbers which unexpectedly succeeded
 752  my @todo_passed = $parser->todo_passed;
 753
 754  # the number of tests which unexpectedly succeeded
 755  my $todo_passed = $parser->todo_passed;
 756
 757 This method lets you know which (or how many) tests actually passed but were
 758 declared as "TODO" tests.
 759
 760 =cut
 761
 762 sub todo_passed { @{ shift->{todo_passed} } }
 763
 764 ##############################################################################
 765
 766 =head3 C<todo_failed>
 767
 768   # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
 769
 770 This was a badly misnamed method.  It indicates which TODO tests unexpectedly
 771 succeeded.  Will now issue a warning and call C<todo_passed>.
 772
 773 =cut
 774
 775 sub todo_failed {
 776     warn
 777       '"todo_failed" is deprecated.  Please use "todo_passed".  See the docs.';
 778     goto &todo_passed;
 779 }
 780
 781 =head3 C<skipped>
 782
 783  my @skipped = $parser->skipped; # the test numbers with SKIP directives
 784  my $skipped = $parser->skipped; # the number of tests with SKIP directives
 785
 786 This method lets you know which (or how many) tests had SKIP directives.
 787
 788 =cut
 789
 790 sub skipped { @{ shift->{skipped} } }
 791
 792 =head2 Summary Results
 793
 794 These results are "meta" information about the total results of an individual
 795 test program.
 796
 797 =head3 C<plan>
 798
 799  my $plan = $parser->plan;
 800
 801 Returns the test plan, if found.
 802
 803 =head3 C<good_plan>
 804
 805 Deprecated.  Use C<is_good_plan> instead.
 806
 807 =cut
 808
 809 sub good_plan {
 810     warn 'good_plan() is deprecated.  Please use "is_good_plan()"';
 811     goto &is_good_plan;
 812 }
 813
 814 ##############################################################################
 815
 816 =head3 C<is_good_plan>
 817
 818   if ( $parser->is_good_plan ) { ... }
 819
 820 Returns a boolean value indicating whether or not the number of tests planned
 821 matches the number of tests run.
 822
 823 B<Note:>  this was formerly C<good_plan>.  The latter method is deprecated and
 824 will issue a warning.
 825
 826 And since we're on that subject ...
 827
 828 =head3 C<tests_planned>
 829
 830   print $parser->tests_planned;
 831
 832 Returns the number of tests planned, according to the plan.  For example, a
 833 plan of '1..17' will mean that 17 tests were planned.
 834
 835 =head3 C<tests_run>
 836
 837   print $parser->tests_run;
 838
 839 Returns the number of tests which actually were run.  Hopefully this will
 840 match the number of C<< $parser->tests_planned >>.
 841
 842 =head3 C<skip_all>
 843
 844 Returns a true value (actually the reason for skipping) if all tests
 845 were skipped.
 846
 847 =head3 C<start_time>
 848
 849 Returns the time when the Parser was created.
 850
 851 =head3 C<end_time>
 852
 853 Returns the time when the end of TAP input was seen.
 854
 855 =head3 C<has_problems>
 856
 857   if ( $parser->has_problems ) {
 858       ...
 859   }
 860
 861 This is a 'catch-all' method which returns true if any tests have currently
 862 failed, any TODO tests unexpectedly succeeded, or any parse errors occurred.
 863
 864 =cut
 865
 866 sub has_problems {
 867     my $self = shift;
 868     return
 869          $self->failed
 870       || $self->parse_errors
 871       || $self->wait
 872       || $self->exit;
 873 }
 874
 875 =head3 C<version>
 876
 877   $parser->version;
 878
 879 Once the parser is done, this will return the version number for the
 880 parsed TAP. Version numbers were introduced with TAP version 13 so if no
 881 version number is found version 12 is assumed.
 882
 883 =head3 C<exit>
 884
 885   $parser->exit;
 886
 887 Once the parser is done, this will return the exit status.  If the parser ran
 888 an executable, it returns the exit status of the executable.
 889
 890 =head3 C<wait>
 891
 892   $parser->wait;
 893
 894 Once the parser is done, this will return the wait status.  If the parser ran
 895 an executable, it returns the wait status of the executable.  Otherwise, this
 896 mererely returns the C<exit> status.
 897
 898 =head3 C<parse_errors>
 899
 900  my @errors = $parser->parse_errors; # the parser errors
 901  my $errors = $parser->parse_errors; # the number of parser_errors
 902
 903 Fortunately, all TAP output is perfect.  In the event that it is not, this
 904 method will return parser errors.  Note that a junk line which the parser does
 905 not recognize is C<not> an error.  This allows this parser to handle future
 906 versions of TAP.  The following are all TAP errors reported by the parser:
 907
 908 =over 4
 909
 910 =item * Misplaced plan
 911
 912 The plan (for example, '1..5'), must only come at the beginning or end of the
 913 TAP output.
 914
 915 =item * No plan
 916
 917 Gotta have a plan!
 918
 919 =item * More than one plan
 920
 921  1..3
 922  ok 1 - input file opened
 923  not ok 2 - first line of the input valid # todo some data
 924  ok 3 read the rest of the file
 925  1..3
 926
 927 Right.  Very funny.  Don't do that.
 928
 929 =item * Test numbers out of sequence
 930
 931  1..3
 932  ok 1 - input file opened
 933  not ok 2 - first line of the input valid # todo some data
 934  ok 2 read the rest of the file
 935
 936 That last test line above should have the number '3' instead of '2'.
 937
 938 Note that it's perfectly acceptable for some lines to have test numbers and
 939 others to not have them.  However, when a test number is found, it must be in
 940 sequence.  The following is also an error:
 941
 942  1..3
 943  ok 1 - input file opened
 944  not ok - first line of the input valid # todo some data
 945  ok 2 read the rest of the file
 946
 947 But this is not:
 948
 949  1..3
 950  ok  - input file opened
 951  not ok - first line of the input valid # todo some data
 952  ok 3 read the rest of the file
 953
 954 =back
 955
 956 =cut
 957
 958 sub parse_errors { @{ shift->{parse_errors} } }
 959
 960 sub _add_error {
 961     my ( $self, $error ) = @_;
 962     push @{ $self->{parse_errors} } => $error;
 963     return $self;
 964 }
 965
 966 sub _make_state_table {
 967     my $self = shift;
 968     my %states;
 969     my %planned_todo = ();
 970
 971     # These transitions are defaults for all states
 972     my %state_globals = (
 973         comment => {},
 974         bailout => {},
 975         version => {
 976             act => sub {
 977                 my ($version) = @_;
 978                 $self->_add_error(
 979                     'If TAP version is present it must be the first line of output'
 980                 );
 981             },
 982         },
 983     );
 984
 985     # Provides default elements for transitions
 986     my %state_defaults = (
 987         plan => {
 988             act => sub {
 989                 my ($plan) = @_;
 990                 $self->tests_planned( $plan->tests_planned );
 991                 $self->plan( $plan->plan );
 992                 if ( $plan->has_skip ) {
 993                     $self->skip_all( $plan->explanation
 994                           || '(no reason given)' );
 995                 }
 996
 997                 $planned_todo{$_}++ for @{ $plan->todo_list };
 998             },
 999         },
1000         test => {
1001             act => sub {
1002                 my ($test) = @_;
1003
1004                 my ( $number, $tests_run )
1005                   = ( $test->number, ++$self->{tests_run} );
1006
1007                 # Fake TODO state
1008                 if ( defined $number && delete $planned_todo{$number} ) {
1009                     $test->set_directive('TODO');
1010                 }
1011
1012                 my $has_todo = $test->has_todo;
1013
1014                 $self->in_todo($has_todo);
1015                 if ( defined( my $tests_planned = $self->tests_planned ) ) {
1016                     if ( $tests_run > $tests_planned ) {
1017                         $test->is_unplanned(1);
1018                     }
1019                 }
1020
1021                 if ($number) {
1022                     if ( $number != $tests_run ) {
1023                         my $count = $tests_run;
1024                         $self->_add_error( "Tests out of sequence.  Found "
1025                               . "($number) but expected ($count)" );
1026                     }
1027                 }
1028                 else {
1029                     $test->_number( $number = $tests_run );
1030                 }
1031
1032                 push @{ $self->{todo} } => $number if $has_todo;
1033                 push @{ $self->{todo_passed} } => $number
1034                   if $test->todo_passed;
1035                 push @{ $self->{skipped} } => $number
1036                   if $test->has_skip;
1037
1038                 push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
1039                   $number;
1040                 push @{
1041                     $self->{
1042                         $test->is_actual_ok
1043                         ? 'actual_passed'
1044                         : 'actual_failed'
1045                       }
1046                   } => $number;
1047             },
1048         },
1049         yaml => {
1050             act => sub { },
1051         },
1052     );
1053
1054     # Each state contains a hash the keys of which match a token type. For
1055     # each token
1056     # type there may be:
1057     #   act      A coderef to run
1058     #   goto     The new state to move to. Stay in this state if
1059     #            missing
1060     #   continue Goto the new state and run the new state for the
1061     #            current token
1062     %states = (
1063         INIT => {
1064             version => {
1065                 act => sub {
1066                     my ($version) = @_;
1067                     my $ver_num = $version->version;
1068                     if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
1069                         my $ver_min = $DEFAULT_TAP_VERSION + 1;
1070                         $self->_add_error(
1071                                 "Explicit TAP version must be at least "
1072                               . "$ver_min. Got version $ver_num" );
1073                         $ver_num = $DEFAULT_TAP_VERSION;
1074                     }
1075                     if ( $ver_num > $MAX_TAP_VERSION ) {
1076                         $self->_add_error(
1077                                 "TAP specified version $ver_num but "
1078                               . "we don't know about versions later "
1079                               . "than $MAX_TAP_VERSION" );
1080                         $ver_num = $MAX_TAP_VERSION;
1081                     }
1082                     $self->version($ver_num);
1083                     $self->_grammar->set_version($ver_num);
1084                 },
1085                 goto => 'PLAN'
1086             },
1087             plan => { goto => 'PLANNED' },
1088             test => { goto => 'UNPLANNED' },
1089         },
1090         PLAN => {
1091             plan => { goto => 'PLANNED' },
1092             test => { goto => 'UNPLANNED' },
1093         },
1094         PLANNED => {
1095             test => { goto => 'PLANNED_AFTER_TEST' },
1096             plan => {
1097                 act => sub {
1098                     my ($version) = @_;
1099                     $self->_add_error(
1100                         'More than one plan found in TAP output');
1101                 },
1102             },
1103         },
1104         PLANNED_AFTER_TEST => {
1105             test => { goto => 'PLANNED_AFTER_TEST' },
1106             plan => { act  => sub { }, continue => 'PLANNED' },
1107             yaml => { goto => 'PLANNED' },
1108         },
1109         GOT_PLAN => {
1110             test => {
1111                 act => sub {
1112                     my ($plan) = @_;
1113                     my $line = $self->plan;
1114                     $self->_add_error(
1115                             "Plan ($line) must be at the beginning "
1116                           . "or end of the TAP output" );
1117                     $self->is_good_plan(0);
1118                 },
1119                 continue => 'PLANNED'
1120             },
1121             plan => { continue => 'PLANNED' },
1122         },
1123         UNPLANNED => {
1124             test => { goto => 'UNPLANNED_AFTER_TEST' },
1125             plan => { goto => 'GOT_PLAN' },
1126         },
1127         UNPLANNED_AFTER_TEST => {
1128             test => { act  => sub { }, continue => 'UNPLANNED' },
1129             plan => { act  => sub { }, continue => 'UNPLANNED' },
1130             yaml => { goto => 'PLANNED' },
1131         },
1132     );
1133
1134     # Apply globals and defaults to state table
1135     for my $name ( sort keys %states ) {
1136
1137         # Merge with globals
1138         my $st = { %state_globals, %{ $states{$name} } };
1139
1140         # Add defaults
1141         for my $next ( sort keys %{$st} ) {
1142             if ( my $default = $state_defaults{$next} ) {
1143                 for my $def ( sort keys %{$default} ) {
1144                     $st->{$next}->{$def} ||= $default->{$def};
1145                 }
1146             }
1147         }
1148
1149         # Stuff back in table
1150         $states{$name} = $st;
1151     }
1152
1153     return \%states;
1154 }
1155
1156 =head3 C<get_select_handles>
1157
1158 Get an a list of file handles which can be passed to C<select> to
1159 determine the readiness of this parser.
1160
1161 =cut
1162
1163 sub get_select_handles { shift->_stream->get_select_handles }
1164
1165 sub _iter {
1166     my $self        = shift;
1167     my $stream      = $self->_stream;
1168     my $spool       = $self->_spool;
1169     my $grammar     = $self->_grammar;
1170     my $state       = 'INIT';
1171     my $state_table = $self->_make_state_table;
1172
1173     # Make next_state closure
1174     my $next_state = sub {
1175         my $token = shift;
1176         my $type  = $token->type;
1177         my $count = 1;
1178         TRANS: {
1179             my $state_spec = $state_table->{$state}
1180               or die "Illegal state: $state";
1181
1182             if ( my $next = $state_spec->{$type} ) {
1183                 if ( my $act = $next->{act} ) {
1184                     $act->($token);
1185                 }
1186                 if ( my $cont = $next->{continue} ) {
1187                     $state = $cont;
1188                     redo TRANS;
1189                 }
1190                 elsif ( my $goto = $next->{goto} ) {
1191                     $state = $goto;
1192                 }
1193             }
1194         }
1195         return $token;
1196     };
1197
1198     # Handle end of stream - which means either pop a block or finish
1199     my $end_handler = sub {
1200         $self->exit( $stream->exit );
1201         $self->wait( $stream->wait );
1202         $self->_finish;
1203         return;
1204     };
1205
1206     # Finally make the closure that we return. For performance reasons
1207     # there are two versions of the returned function: one that handles
1208     # callbacks and one that does not.
1209     if ( $self->_has_callbacks ) {
1210         return sub {
1211             my $result = eval { $grammar->tokenize };
1212             $self->_add_error($@) if $@;
1213
1214             if ( defined $result ) {
1215                 $result = $next_state->($result);
1216
1217                 if ( my $code = $self->_callback_for( $result->type ) ) {
1218                     $_->($result) for @{$code};
1219                 }
1220                 else {
1221                     $self->_make_callback( 'ELSE', $result );
1222                 }
1223
1224                 $self->_make_callback( 'ALL', $result );
1225
1226                 # Echo TAP to spool file
1227                 print {$spool} $result->raw, "\n" if $spool;
1228             }
1229             else {
1230                 $result = $end_handler->();
1231                 $self->_make_callback( 'EOF', $result )
1232                   unless defined $result;
1233             }
1234
1235             return $result;
1236         };
1237     }    # _has_callbacks
1238     else {
1239         return sub {
1240             my $result = eval { $grammar->tokenize };
1241             $self->_add_error($@) if $@;
1242
1243             if ( defined $result ) {
1244                 $result = $next_state->($result);
1245
1246                 # Echo TAP to spool file
1247                 print {$spool} $result->raw, "\n" if $spool;
1248             }
1249             else {
1250                 $result = $end_handler->();
1251             }
1252
1253             return $result;
1254         };
1255     }    # no callbacks
1256 }
1257
1258 sub _finish {
1259     my $self = shift;
1260
1261     $self->end_time( $self->get_time );
1262
1263     # sanity checks
1264     if ( !$self->plan ) {
1265         $self->_add_error('No plan found in TAP output');
1266     }
1267     else {
1268         $self->is_good_plan(1) unless defined $self->is_good_plan;
1269     }
1270     if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
1271         $self->is_good_plan(0);
1272         if ( defined( my $planned = $self->tests_planned ) ) {
1273             my $ran = $self->tests_run;
1274             $self->_add_error(
1275                 "Bad plan.  You planned $planned tests but ran $ran.");
1276         }
1277     }
1278     if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
1279
1280         # this should never happen
1281         my $actual = $self->tests_run;
1282         my $passed = $self->passed;
1283         my $failed = $self->failed;
1284         $self->_croak( "Panic: planned test count ($actual) did not equal "
1285               . "sum of passed ($passed) and failed ($failed) tests!" );
1286     }
1287
1288     $self->is_good_plan(0) unless defined $self->is_good_plan;
1289     return $self;
1290 }
1291
1292 =head3 C<delete_spool>
1293
1294 Delete and return the spool.
1295
1296   my $fh = $parser->delete_spool;
1297
1298 =cut
1299
1300 sub delete_spool {
1301     my $self = shift;
1302
1303     return delete $self->{_spool};
1304 }
1305
1306 ##############################################################################
1307
1308 =head1 CALLBACKS
1309
1310 As mentioned earlier, a "callback" key may be added to the
1311 C<TAP::Parser> constructor. If present, each callback corresponding to a
1312 given result type will be called with the result as the argument if the
1313 C<run> method is used. The callback is expected to be a subroutine
1314 reference (or anonymous subroutine) which is invoked with the parser
1315 result as its argument.
1316
1317  my %callbacks = (
1318      test    => \&test_callback,
1319      plan    => \&plan_callback,
1320      comment => \&comment_callback,
1321      bailout => \&bailout_callback,
1322      unknown => \&unknown_callback,
1323  );
1324
1325  my $aggregator = TAP::Parser::Aggregator->new;
1326  foreach my $file ( @test_files ) {
1327      my $parser = TAP::Parser->new(
1328          {
1329              source    => $file,
1330              callbacks => \%callbacks,
1331          }
1332      );
1333      $parser->run;
1334      $aggregator->add( $file, $parser );
1335  }
1336
1337 Callbacks may also be added like this:
1338
1339  $parser->callback( test => \&test_callback );
1340  $parser->callback( plan => \&plan_callback );
1341
1342 The following keys allowed for callbacks. These keys are case-sensitive.
1343
1344 =over 4
1345
1346 =item * C<test>
1347
1348 Invoked if C<< $result->is_test >> returns true.
1349
1350 =item * C<version>
1351
1352 Invoked if C<< $result->is_version >> returns true.
1353
1354 =item * C<plan>
1355
1356 Invoked if C<< $result->is_plan >> returns true.
1357
1358 =item * C<comment>
1359
1360 Invoked if C<< $result->is_comment >> returns true.
1361
1362 =item * C<bailout>
1363
1364 Invoked if C<< $result->is_unknown >> returns true.
1365
1366 =item * C<yaml>
1367
1368 Invoked if C<< $result->is_yaml >> returns true.
1369
1370 =item * C<unknown>
1371
1372 Invoked if C<< $result->is_unknown >> returns true.
1373
1374 =item * C<ELSE>
1375
1376 If a result does not have a callback defined for it, this callback will
1377 be invoked. Thus, if all of the previous result types are specified as
1378 callbacks, this callback will I<never> be invoked.
1379
1380 =item * C<ALL>
1381
1382 This callback will always be invoked and this will happen for each
1383 result after one of the above callbacks is invoked.  For example, if
1384 L<Term::ANSIColor> is loaded, you could use the following to color your
1385 test output:
1386
1387  my %callbacks = (
1388      test => sub {
1389          my $test = shift;
1390          if ( $test->is_ok && not $test->directive ) {
1391              # normal passing test
1392              print color 'green';
1393          }
1394          elsif ( !$test->is_ok ) {    # even if it's TODO
1395              print color 'white on_red';
1396          }
1397          elsif ( $test->has_skip ) {
1398              print color 'white on_blue';
1399
1400          }
1401          elsif ( $test->has_todo ) {
1402              print color 'white';
1403          }
1404      },
1405      ELSE => sub {
1406          # plan, comment, and so on (anything which isn't a test line)
1407          print color 'black on_white';
1408      },
1409      ALL => sub {
1410          # now print them
1411          print shift->as_string;
1412          print color 'reset';
1413          print "\n";
1414      },
1415  );
1416
1417 =item * C<EOF>
1418
1419 Invoked when there are no more lines to be parsed. Since there is no
1420 accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
1421 passed instead.
1422
1423 =back
1424
1425 =head1 TAP GRAMMAR
1426
1427 If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
1428
1429 =head1 BACKWARDS COMPATABILITY
1430
1431 The Perl-QA list attempted to ensure backwards compatability with
1432 L<Test::Harness>.  However, there are some minor differences.
1433
1434 =head2 Differences
1435
1436 =over 4
1437
1438 =item * TODO plans
1439
1440 A little-known feature of L<Test::Harness> is that it supported TODO
1441 lists in the plan:
1442
1443  1..2 todo 2
1444  ok 1 - We have liftoff
1445  not ok 2 - Anti-gravity device activated
1446
1447 Under L<Test::Harness>, test number 2 would I<pass> because it was
1448 listed as a TODO test on the plan line. However, we are not aware of
1449 anyone actually using this feature and hard-coding test numbers is
1450 discouraged because it's very easy to add a test and break the test
1451 number sequence. This makes test suites very fragile. Instead, the
1452 following should be used:
1453
1454  1..2
1455  ok 1 - We have liftoff
1456  not ok 2 - Anti-gravity device activated # TODO
1457
1458 =item * 'Missing' tests
1459
1460 It rarely happens, but sometimes a harness might encounter
1461 'missing tests:
1462
1463  ok 1
1464  ok 2
1465  ok 15
1466  ok 16
1467  ok 17
1468
1469 L<Test::Harness> would report tests 3-14 as having failed. For the
1470 C<TAP::Parser>, these tests are not considered failed because they've
1471 never run. They're reported as parse failures (tests out of sequence).
1472
1473 =back
1474
1475 =head1 ACKNOWLEDGEMENTS
1476
1477 All of the following have helped. Bug reports, patches, (im)moral
1478 support, or just words of encouragement have all been forthcoming.
1479
1480 =over 4
1481
1482 =item * Michael Schwern
1483
1484 =item * Andy Lester
1485
1486 =item * chromatic
1487
1488 =item * GEOFFR
1489
1490 =item * Shlomi Fish
1491
1492 =item * Torsten Schoenfeld
1493
1494 =item * Jerry Gay
1495
1496 =item * Aristotle
1497
1498 =item * Adam Kennedy
1499
1500 =item * Yves Orton
1501
1502 =item * Adrian Howard
1503
1504 =item * Sean & Lil
1505
1506 =item * Andreas J. Koenig
1507
1508 =item * Florian Ragwitz
1509
1510 =item * Corion
1511
1512 =item * Mark Stosberg
1513
1514 =item * Matt Kraai
1515
1516 =back
1517
1518 =head1 AUTHORS
1519
1520 Curtis "Ovid" Poe <ovid@cpan.org>
1521
1522 Andy Armstong <andy@hexten.net>
1523
1524 Eric Wilhelm @ <ewilhelm at cpan dot org>
1525
1526 Michael Peters <mpeters at plusthree dot com>
1527
1528 Leif Eriksen <leif dot eriksen at bigpond dot com>
1529
1530 =head1 BUGS
1531
1532 Please report any bugs or feature requests to
1533 C<bug-tapx-parser@rt.cpan.org>, or through the web interface at
1534 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
1535 We will be notified, and then you'll automatically be notified of
1536 progress on your bug as we make changes.
1537
1538 Obviously, bugs which include patches are best. If you prefer, you can
1539 patch against bleed by via anonymous checkout of the latest version:
1540
1541  svn checkout http://svn.hexten.net/tapx
1542
1543 =head1 COPYRIGHT & LICENSE
1544
1545 Copyright 2006-2007 Curtis "Ovid" Poe, all rights reserved.
1546
1547 This program is free software; you can redistribute it and/or modify it
1548 under the same terms as Perl itself.
1549
1550 =cut
1551
1552 1;