This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File::Copy & permission bits.
[perl5.git] / 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;