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