From: Nicholas Clark Date: Wed, 19 Dec 2007 18:18:04 +0000 (+0000) Subject: Upgrade to Test::Harness 3.05 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b965d173aab5196552f8fc4ba42e0913bbdb8d25;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test::Harness 3.05 Add test boilerplate to various test files. Add FIXME skips for various tests that don't play nicely with the altered layout in the core. lib/Test/Harness/t/unicode.t appears to fail under UTF-8 locales and so will need fixing. p4raw-id: //depot/perl@32659 --- diff --git a/MANIFEST b/MANIFEST index 69f358d..03a20b4 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1388,6 +1388,8 @@ keywords.pl Program to write keywords.h lib/abbrev.pl An abbreviation table builder lib/AnyDBM_File.pm Perl module to emulate dbmopen lib/AnyDBM_File.t See if AnyDBM_File works +lib/App/Prove.pm Gubbins for the prove utility +lib/App/Prove/State.pm Gubbins for the prove utility lib/Archive/Extract.pm Archive::Extract lib/Archive/Extract/t/01_Archive-Extract.t Archive::Extract tests lib/Archive/Extract/t/src/double_dir.zip.packed Archive::Extract tests @@ -2579,6 +2581,32 @@ lib/Symbol.pm Symbol table manipulation routines lib/Symbol.t See if Symbol works lib/syslog.pl Perl library supporting syslogging lib/tainted.pl Old code for tainting +lib/TAP/Base.pm A parser for Test Anything Protocol +lib/TAP/Formatter/Color.pm A parser for Test Anything Protocol +lib/TAP/Formatter/Console.pm A parser for Test Anything Protocol +lib/TAP/Formatter/Console/ParallelSession.pm A parser for Test Anything Protocol +lib/TAP/Formatter/Console/Session.pm A parser for Test Anything Protocol +lib/TAP/Harness.pm A parser for Test Anything Protocol +lib/TAP/Parser.pm A parser for Test Anything Protocol +lib/TAP/Parser/Aggregator.pm A parser for Test Anything Protocol +lib/TAP/Parser/Grammar.pm A parser for Test Anything Protocol +lib/TAP/Parser/Iterator.pm A parser for Test Anything Protocol +lib/TAP/Parser/Iterator/Array.pm A parser for Test Anything Protocol +lib/TAP/Parser/Iterator/Process.pm A parser for Test Anything Protocol +lib/TAP/Parser/Iterator/Stream.pm A parser for Test Anything Protocol +lib/TAP/Parser/Multiplexer.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/Bailout.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/Comment.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/Plan.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/Test.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/Unknown.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/Version.pm A parser for Test Anything Protocol +lib/TAP/Parser/Result/YAML.pm A parser for Test Anything Protocol +lib/TAP/Parser/Source.pm A parser for Test Anything Protocol +lib/TAP/Parser/Source/Perl.pm A parser for Test Anything Protocol +lib/TAP/Parser/YAMLish/Reader.pm A parser for Test Anything Protocol +lib/TAP/Parser/YAMLish/Writer.pm A parser for Test Anything Protocol lib/Term/ANSIColor/ChangeLog Term::ANSIColor lib/Term/ANSIColor.pm Perl module supporting termcap usage lib/Term/ANSIColor/README Term::ANSIColor @@ -2599,34 +2627,48 @@ lib/Test/Builder/Module.pm Base class for test modules lib/Test/Builder.pm For writing new test libraries lib/Test/Builder/Tester/Color.pm Turn on color in Test::Builder::Tester lib/Test/Builder/Tester.pm For testing Test::Builder based classes -lib/Test/Harness/Assert.pm Test::Harness::Assert (internal use only) lib/Test/Harness/bin/prove The prove harness utility -lib/Test/Harness/Changes Test::Harness -lib/Test/Harness/Iterator.pm Test::Harness::Iterator (internal use only) +lib/Test/Harness/Changes Test::Harness change log lib/Test/Harness.pm A test harness -lib/Test/Harness/Point.pm Test::Harness::Point (internal use only) -lib/Test/Harness/Results.pm object for tracking results from a single test file -lib/Test/Harness/Straps.pm Test::Harness::Straps -lib/Test/Harness/t/00compile.t Test::Harness test -lib/Test/Harness/TAP.pod Documentation for the Test Anything Protocol -lib/Test/Harness/t/assert.t Test::Harness::Assert test -lib/Test/Harness/t/base.t Test::Harness test -lib/Test/Harness/t/callback.t Test::Harness test -lib/Test/Harness/t/failure.t Test::Harness test -lib/Test/Harness/t/from_line.t Test::Harness test -lib/Test/Harness/t/harness.t Test::Harness test -lib/Test/Harness/t/inc_taint.t Test::Harness test -lib/Test/Harness/t/nonumbers.t Test::Harness test -lib/Test/Harness/t/ok.t Test::Harness test -lib/Test/Harness/t/point-parse.t Test::Harness test -lib/Test/Harness/t/point.t Test::Harness test -lib/Test/Harness/t/prove-globbing.t Test::Harness::Straps test -lib/Test/Harness/t/prove-switches.t Test::Harness::Straps test -lib/Test/Harness/t/strap-analyze.t Test::Harness::Straps test -lib/Test/Harness/t/strap.t Test::Harness::Straps test -lib/Test/Harness/t/test-harness.t Test::Harness test -lib/Test/Harness/t/version.t Test::Harness test -lib/Test/Harness/Util.pm Various utility functions for Test::Harness +lib/Test/Harness/t/000-load.t Test::Harness test +lib/Test/Harness/t/aggregator.t Test::Harness test +lib/Test/Harness/t/bailout.t Test::Harness test +lib/Test/Harness/t/base.t Test::Harness test +lib/Test/Harness/t/callbacks.t Test::Harness test +lib/Test/Harness/t/compat/env.t Test::Harness test +lib/Test/Harness/t/compat/failure.t Test::Harness test +lib/Test/Harness/t/compat/inc-propagation.t Test::Harness test +lib/Test/Harness/t/compat/inc_taint.t Test::Harness test +lib/Test/Harness/t/compat/nonumbers.t Test::Harness test +lib/Test/Harness/t/compat/regression.t Test::Harness test +lib/Test/Harness/t/compat/test-harness-compat.t Test::Harness test +lib/Test/Harness/t/compat/version.t Test::Harness test +lib/Test/Harness/t/console.t Test::Harness test +lib/Test/Harness/t/errors.t Test::Harness test +lib/Test/Harness/t/grammar.t Test::Harness test +lib/Test/Harness/t/harness.t Test::Harness test +lib/Test/Harness/t/iterators.t Test::Harness test +lib/Test/Harness/t/multiplexer.t Test::Harness test +lib/Test/Harness/t/nofork-mux.t Test::Harness test +lib/Test/Harness/t/nofork.t Test::Harness test +lib/Test/Harness/t/parse.t Test::Harness test +lib/Test/Harness/t/premature-bailout.t Test::Harness test +lib/Test/Harness/t/process.t Test::Harness test +lib/Test/Harness/t/prove.t Test::Harness test +lib/Test/Harness/t/proverc.t Test::Harness test +lib/Test/Harness/t/proverun.t Test::Harness test +lib/Test/Harness/t/regression.t Test::Harness test +lib/Test/Harness/t/results.t Test::Harness test +lib/Test/Harness/t/source.t Test::Harness test +lib/Test/Harness/t/spool.t Test::Harness test +lib/Test/Harness/t/state.t Test::Harness test +lib/Test/Harness/t/streams.t Test::Harness test +lib/Test/Harness/t/taint.t Test::Harness test +lib/Test/Harness/t/testargs.t Test::Harness test +lib/Test/Harness/t/unicode.t Test::Harness test +lib/Test/Harness/t/yamlish-output.t Test::Harness test +lib/Test/Harness/t/yamlish-writer.t Test::Harness test +lib/Test/Harness/t/yamlish.t Test::Harness test lib/Test/More.pm More utilities for writing tests lib/Test.pm A simple framework for writing test scripts lib/Test/Simple/Changes Test::Simple changes @@ -3467,6 +3509,7 @@ t/lib/compress/truncate.pl Compress::Zlib t/lib/compress/zlib-generic.pl Compress::Zlib t/lib/contains_pod.xr Pod-Parser test file t/lib/cygwin.t Builtin cygwin function tests +t/lib/App/Prove/Plugin/Dummy.pm Module for testing Test::Harness t/lib/Devel/switchd.pm Module for t/run/switchd.t t/lib/Dev/Null.pm Module for testing Test::Harness t/lib/dprof/test1_t Perl code profiler tests @@ -3499,6 +3542,7 @@ t/lib/filter-util.pl See if Filter::Util::Call works t/lib/h2ph.h Test header file for h2ph t/lib/h2ph.pht Generated output from h2ph.h by h2ph, for comparison t/lib/HasSigDie.pm Module for testing base.pm +t/lib/IO/c55Capture.pm Module for testing Test::Harness t/lib/locale/latin1 Part of locale.t in Latin 1 t/lib/locale/utf8 Part of locale.t in UTF8 t/lib/MakeMaker/Test/Setup/BFD.pm MakeMaker test utilities @@ -3515,40 +3559,71 @@ t/lib/Math/BigRat/Test.pm Math::BigRat test helper t/lib/mypragma.pm An example user pragma t/lib/mypragma.t Test the example user pragma t/lib/NoExporter.pm Part of Test-Simple +t/lib/NoFork.pm Module for testing Test::Harness t/lib/no_load.t Test that some modules don't load others t/lib/proxy_constant_subs.t Test that Proxy Constant Subs behave correctly +t/lib/data/catme.1 Test data for Test::Harness +t/lib/data/proverc Test data for Test::Harness +t/lib/data/sample.yml Test data for Test::Harness t/lib/sample-tests/bailout Test data for Test::Harness t/lib/sample-tests/bignum Test data for Test::Harness t/lib/sample-tests/bignum_many Test data for Test::Harness t/lib/sample-tests/combined Test data for Test::Harness +t/lib/sample-tests/combined_compat Test data for Test::Harness +t/lib/sample-tests/delayed Test data for Test::Harness t/lib/sample-tests/descriptive Test data for Test::Harness +t/lib/sample-tests/descriptive_trailing Test data for Test::Harness t/lib/sample-tests/die Test data for Test::Harness t/lib/sample-tests/die_head_end Test data for Test::Harness t/lib/sample-tests/die_last_minute Test data for Test::Harness +t/lib/sample-tests/die_unfinished Test data for Test::Harness t/lib/sample-tests/duplicates Test data for Test::Harness +t/lib/sample-tests/echo Test data for Test::Harness +t/lib/sample-tests/empty Test data for Test::Harness +t/lib/sample-tests/escape_eol Test data for Test::Harness +t/lib/sample-tests/escape_hash Test data for Test::Harness t/lib/sample-tests/head_end Test data for Test::Harness t/lib/sample-tests/head_fail Test data for Test::Harness t/lib/sample-tests/inc_taint Test data for Test::Harness +t/lib/sample-tests/junk_before_plan Test data for Test::Harness t/lib/sample-tests/lone_not_bug Test data for Test::Harness t/lib/sample-tests/no_nums Test data for Test::Harness t/lib/sample-tests/no_output Test data for Test::Harness +t/lib/sample-tests/out_err_mix Test data for Test::Harness t/lib/sample-tests/out_of_order Test data for Test::Harness +t/lib/sample-tests/schwern Test data for Test::Harness +t/lib/sample-tests/schwern-todo-quiet Test data for Test::Harness t/lib/sample-tests/segfault Test data for Test::Harness +t/lib/sample-tests/sequence_misparse Test data for Test::Harness t/lib/sample-tests/shbang_misparse Test data for Test::Harness t/lib/sample-tests/simple Test data for Test::Harness t/lib/sample-tests/simple_fail Test data for Test::Harness +t/lib/sample-tests/simple_yaml Test data for Test::Harness t/lib/sample-tests/skip Test data for Test::Harness +t/lib/sample-tests/skip_nomsg Test data for Test::Harness t/lib/sample-tests/skipall Test data for Test::Harness t/lib/sample-tests/skipall_nomsg Test data for Test::Harness -t/lib/sample-tests/skip_nomsg Test data for Test::Harness +t/lib/sample-tests/skipall_v13 Test data for Test::Harness +t/lib/sample-tests/space_after_plan Test data for Test::Harness +t/lib/sample-tests/stdout_stderr Test data for Test::Harness t/lib/sample-tests/switches Test data for Test::Harness t/lib/sample-tests/taint Test data for Test::Harness t/lib/sample-tests/taint_warn Test data for Test::Harness t/lib/sample-tests/todo Test data for Test::Harness t/lib/sample-tests/todo_inline Test data for Test::Harness +t/lib/sample-tests/todo_misparse Test data for Test::Harness t/lib/sample-tests/too_many Test data for Test::Harness +t/lib/sample-tests/version_good Test data for Test::Harness +t/lib/sample-tests/version_late Test data for Test::Harness +t/lib/sample-tests/version_old Test data for Test::Harness t/lib/sample-tests/vms_nit Test data for Test::Harness t/lib/sample-tests/with_comments Test data for Test::Harness +t/lib/source_tests/harness Test data for Test::Harness +t/lib/source_tests/harness_badtap Test data for Test::Harness +t/lib/source_tests/harness_complain Test data for Test::Harness +t/lib/source_tests/harness_directives Test data for Test::Harness +t/lib/source_tests/harness_failure Test data for Test::Harness +t/lib/source_tests/source Test data for Test::Harness t/lib/strict/refs Tests of "use strict 'refs'" for strict.t t/lib/strict/subs Tests of "use strict 'subs'" for strict.t t/lib/strict/vars Tests of "use strict 'vars'" for strict.t diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 6a7753a..5661297 100644 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -14,6 +14,7 @@ package Maintainers; 'abigail' => 'Abigail ', 'ams' => 'Abhijit Menon-Sen ', 'andk' => 'Andreas J. Koenig ', + 'andya' => 'Andy Armstrong ', 'arandal' => 'Allison Randal ', 'audreyt' => 'Audrey Tang ', 'avar' => 'Ævar Arnfjörð Bjarmason ', @@ -846,9 +847,13 @@ package Maintainers; 'Test::Harness' => { - 'MAINTAINER' => 'petdance', - 'FILES' => q[lib/Test/Harness.pm lib/Test/Harness - t/lib/sample-tests], + 'MAINTAINER' => 'andya', + 'FILES' => q[lib/App/Prove.pm lib/App/Prove/State.pm + lib/Test/Harness.pm lib/Test/Harness + t/lib/data t/lib/sample-tests + t/lib/source_tests t/lib/Dev/Null.pm + t/lib/App/Prove/Plugin/Dummy.pm + t/lib/IO/c55Capture.pm t/lib/NoFork.pm], 'CPAN' => 1, }, diff --git a/lib/TAP/Base.pm b/lib/TAP/Base.pm new file mode 100644 index 0000000..3985f7b --- /dev/null +++ b/lib/TAP/Base.pm @@ -0,0 +1,143 @@ +package TAP::Base; + +use strict; +use vars qw($VERSION); + +=head1 NAME + +TAP::Base - Base class that provides common functionality to L and L + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +my $GOT_TIME_HIRES; + +BEGIN { + eval 'use Time::HiRes qw(time);'; + $GOT_TIME_HIRES = $@ ? 0 : 1; +} + +=head1 SYNOPSIS + + package TAP::Whatever; + + use TAP::Base; + + use vars qw($VERSION @ISA); + @ISA = qw(TAP::Base); + + # ... later ... + + my $thing = TAP::Whatever->new(); + + $thing->callback( event => sub { + # do something interesting + } ); + +=head1 DESCRIPTION + +C provides callback management. + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +=cut + +sub new { + my ( $class, $arg_for ) = @_; + + my $self = bless {}, $class; + return $self->_initialize($arg_for); +} + +sub _initialize { + my ( $self, $arg_for, $ok_callback ) = @_; + + my %ok_map = map { $_ => 1 } @$ok_callback; + + $self->{ok_callbacks} = \%ok_map; + + if ( my $cb = delete $arg_for->{callbacks} ) { + while ( my ( $event, $callback ) = each %$cb ) { + $self->callback( $event, $callback ); + } + } + + return $self; +} + +=head3 C + +Install a callback for a named event. + +=cut + +sub callback { + my ( $self, $event, $callback ) = @_; + + my %ok_map = %{ $self->{ok_callbacks} }; + + $self->_croak('No callbacks may be installed') + unless %ok_map; + + $self->_croak( "Callback $event is not supported. Valid callbacks are " + . join( ', ', sort keys %ok_map ) ) + unless exists $ok_map{$event}; + + push @{ $self->{code_for}{$event} }, $callback; + + return; +} + +sub _has_callbacks { + my $self = shift; + return keys %{ $self->{code_for} } != 0; +} + +sub _callback_for { + my ( $self, $event ) = @_; + return $self->{code_for}{$event}; +} + +sub _make_callback { + my $self = shift; + my $event = shift; + + my $cb = $self->_callback_for($event); + return unless defined $cb; + return map { $_->(@_) } @$cb; +} + +sub _croak { + my ( $self, $message ) = @_; + require Carp; + Carp::croak($message); + + return; +} + +=head3 C + +Return the current time using Time::HiRes if available. + +=cut + +sub get_time { return time() } + +=head3 C + +Return true if the time returned by get_time is high resolution (i.e. if Time::HiRes is available). + +=cut + +sub time_is_hires { return $GOT_TIME_HIRES } + +1; diff --git a/lib/TAP/Formatter/Color.pm b/lib/TAP/Formatter/Color.pm new file mode 100644 index 0000000..7529da5 --- /dev/null +++ b/lib/TAP/Formatter/Color.pm @@ -0,0 +1,145 @@ +package TAP::Formatter::Color; + +use strict; + +use vars qw($VERSION); + +use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); + +my $NO_COLOR; + +BEGIN { + $NO_COLOR = 0; + + if (IS_WIN32) { + eval 'use Win32::Console'; + if ($@) { + $NO_COLOR = $@; + } + else { + my $console = Win32::Console->new( STD_OUTPUT_HANDLE() ); + + # eval here because we might not know about these variables + my $fg = eval '$FG_LIGHTGRAY'; + my $bg = eval '$BG_BLACK'; + + *set_color = sub { + my ( $self, $output, $color ) = @_; + + my $var; + if ( $color eq 'reset' ) { + $fg = eval '$FG_LIGHTGRAY'; + $bg = eval '$BG_BLACK'; + } + elsif ( $color =~ /^on_(.+)$/ ) { + $bg = eval '$BG_' . uc($1); + } + else { + $fg = eval '$FG_' . uc($color); + } + + # In case of colors that aren't defined + $self->set_color('reset') + unless defined $bg && defined $fg; + + $console->Attr( $bg | $fg ); + }; + } + } + else { + eval 'use Term::ANSIColor'; + if ($@) { + $NO_COLOR = $@; + } + else { + *set_color = sub { + my ( $self, $output, $color ) = @_; + $output->( color($color) ); + }; + } + } + + if ($NO_COLOR) { + *set_color = sub { }; + } +} + +=head1 NAME + +TAP::Formatter::Color - Run Perl test scripts with color + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +=head1 DESCRIPTION + +Note that this harness is I. You may not like the colors I've +chosen and I haven't yet provided an easy way to override them. + +This test harness is the same as L, but test results are output +in color. Passing tests are printed in green. Failing tests are in red. +Skipped tests are blue on a white background and TODO tests are printed in +white. + +If L cannot be found (or L if running +under Windows) tests will be run without color. + +=head1 SYNOPSIS + + use TAP::Formatter::Color; + my $harness = TAP::Formatter::Color->new( \%args ); + $harness->runtests(@tests); + +=head1 METHODS + +=head2 Class Methods + +=head3 C + +The constructor returns a new C object. If +L is not installed, returns undef. + +=cut + +sub new { + my $class = shift; + + if ($NO_COLOR) { + + # shorten that message a bit + ( my $error = $NO_COLOR ) =~ s/ in \@INC .*//s; + warn "Note: Cannot run tests in color: $error\n"; + return; + } + + return bless {}, $class; +} + +############################################################################## + +=head3 C + + Test::Formatter::Color->can_color() + +Returns a boolean indicating whether or not this module can actually +generate colored output. This will be false if it could not load the +modules needed for the current platform. + +=cut + +sub can_color { + return !$NO_COLOR; +} + +=head3 C + +Set the output color. + +=cut + +1; diff --git a/lib/TAP/Formatter/Console.pm b/lib/TAP/Formatter/Console.pm new file mode 100644 index 0000000..f239ec9 --- /dev/null +++ b/lib/TAP/Formatter/Console.pm @@ -0,0 +1,476 @@ +package TAP::Formatter::Console; + +use strict; +use TAP::Base (); +use POSIX qw(strftime); + +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Base); + +my $MAX_ERRORS = 5; +my %VALIDATION_FOR; + +BEGIN { + %VALIDATION_FOR = ( + directives => sub { shift; shift }, + verbosity => sub { shift; shift }, + timer => sub { shift; shift }, + failures => sub { shift; shift }, + errors => sub { shift; shift }, + color => sub { shift; shift }, + jobs => sub { shift; shift }, + stdout => sub { + my ( $self, $ref ) = @_; + $self->_croak("option 'stdout' needs a filehandle") + unless ( ref $ref || '' ) eq 'GLOB' + or eval { $ref->can('print') }; + return $ref; + }, + ); + + my @getter_setters = qw( + _longest + _tests_without_extensions + _printed_summary_header + _colorizer + ); + + for my $method ( @getter_setters, keys %VALIDATION_FOR ) { + no strict 'refs'; + *$method = sub { + my $self = shift; + return $self->{$method} unless @_; + $self->{$method} = shift; + }; + } +} + +=head1 NAME + +TAP::Formatter::Console - Harness output delegate for default console output + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + + use TAP::Formatter::Console; + my $harness = TAP::Formatter::Console->new( \%args ); + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + $self->verbosity(0); + + for my $name ( keys %VALIDATION_FOR ) { + my $property = delete $arg_for{$name}; + if ( defined $property ) { + my $validate = $VALIDATION_FOR{$name}; + $self->$name( $self->$validate($property) ); + } + } + + if ( my @props = keys %arg_for ) { + $self->_croak( + "Unknown arguments to " . __PACKAGE__ . "::new (@props)" ); + } + + $self->stdout( \*STDOUT ) unless $self->stdout; + + if ( $self->color ) { + require TAP::Formatter::Color; + $self->_colorizer( TAP::Formatter::Color->new ); + } + + return $self; +} + +sub verbose { shift->verbosity >= 1 } +sub quiet { shift->verbosity <= -1 } +sub really_quiet { shift->verbosity <= -2 } +sub silent { shift->verbosity <= -3 } + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + verbose => 1, + ) + my $harness = TAP::Formatter::Console->new( \%args ); + +The constructor returns a new C object. If +a L is created with no C a +C is automatically created. If any of the +following options were given to TAP::Harness->new they well be passed to +this constructor which accepts an optional hashref whose allowed keys are: + +=over 4 + +=item * C + +Set the verbosity level. + +=item * C + +Printing individual test results to STDOUT. + +=item * C + +Append run time for each test to output. Uses L if available. + +=item * C + +Only show test failures (this is a no-op if C is selected). + +=item * C + +Suppressing some test output (mostly failures while tests are running). + +=item * C + +Suppressing everything but the tests summary. + +=item * C + +Suppressing all output. + +=item * C + +If parse errors are found in the TAP output, a note of this will be made +in the summary report. To see all of the parse errors, set this argument to +true: + + errors => 1 + +=item * C + +If set to a true value, only test results with directives will be displayed. +This overrides other settings such as C or C. + +=item * C + +A filehandle for catching standard output. + +=item * C + +If defined specifies whether color output is desired. If C is not +defined it will default to color output if color support is available on +the current platform and output is not being redirected. + +=item * C + +The number of concurrent jobs this formatter will handle. + +=back + +Any keys for which the value is C will be ignored. + +=cut + +# new supplied by TAP::Base + +=head3 C + +Called by Test::Harness before any test output is generated. + +=cut + +sub prepare { + my ( $self, @tests ) = @_; + + my $longest = 0; + + my $tests_without_extensions = 0; + foreach my $test (@tests) { + $longest = length $test if length $test > $longest; + if ( $test !~ /\.\w+$/ ) { + + # TODO: Coverage? + $tests_without_extensions = 1; + } + } + + $self->_tests_without_extensions($tests_without_extensions); + $self->_longest($longest); +} + +sub _format_now { strftime "[%H:%M:%S]", localtime } + +sub _format_name { + my ( $self, $test ) = @_; + my $name = $test; + my $extra = 0; + unless ( $self->_tests_without_extensions ) { + $name =~ s/(\.\w+)$//; # strip the .t or .pm + $extra = length $1; + } + my $periods = '.' x ( $self->_longest + $extra + 4 - length $test ); + + if ( $self->timer ) { + my $stamp = $self->_format_now(); + return "$stamp $name$periods"; + } + else { + return "$name$periods"; + } + +} + +=head3 C + +Called to create a new test session. A test session looks like this: + + my $session = $formatter->open_test( $test, $parser ); + while ( defined( my $result = $parser->next ) ) { + $session->result($result); + exit 1 if $result->is_bailout; + } + $session->close_test; + +=cut + +sub open_test { + my ( $self, $test, $parser ) = @_; + + my $class + = $self->jobs > 1 + ? 'TAP::Formatter::Console::ParallelSession' + : 'TAP::Formatter::Console::Session'; + + eval "require $class"; + $self->_croak($@) if $@; + + my $session = $class->new( + { name => $test, + formatter => $self, + parser => $parser + } + ); + + $session->header; + + return $session; +} + +=head3 C + + $harness->summary( $aggregate ); + +C prints the summary report after all tests are run. The argument is +an aggregate. + +=cut + +sub summary { + my ( $self, $aggregate ) = @_; + + return if $self->silent; + + my @t = $aggregate->descriptions; + my $tests = \@t; + + my $runtime = $aggregate->elapsed_timestr; + + my $total = $aggregate->total; + my $passed = $aggregate->passed; + + if ( $self->timer ) { + $self->_output( $self->_format_now(), "\n" ); + } + + # TODO: Check this condition still works when all subtests pass but + # the exit status is nonzero + + if ( $aggregate->all_passed ) { + $self->_output("All tests successful.\n"); + } + + # ~TODO option where $aggregate->skipped generates reports + if ( $total != $passed or $aggregate->has_problems ) { + $self->_output("\nTest Summary Report"); + $self->_output("\n-------------------\n"); + foreach my $test (@$tests) { + $self->_printed_summary_header(0); + my ($parser) = $aggregate->parsers($test); + $self->_output_summary_failure( + 'failed', " Failed test number(s): ", + $test, $parser + ); + $self->_output_summary_failure( + 'todo_passed', + " TODO passed: ", $test, $parser + ); + + # ~TODO this cannot be the default + #$self->_output_summary_failure( 'skipped', " Tests skipped: " ); + + if ( my $exit = $parser->exit ) { + $self->_summary_test_header( $test, $parser ); + $self->_failure_output(" Non-zero exit status: $exit\n"); + } + + if ( my @errors = $parser->parse_errors ) { + my $explain; + if ( @errors > $MAX_ERRORS && !$self->errors ) { + $explain + = "Displayed the first $MAX_ERRORS of " + . scalar(@errors) + . " TAP syntax errors.\n" + . "Re-run prove with the -p option to see them all.\n"; + splice @errors, $MAX_ERRORS; + } + $self->_summary_test_header( $test, $parser ); + $self->_failure_output( + sprintf " Parse errors: %s\n", + shift @errors + ); + foreach my $error (@errors) { + my $spaces = ' ' x 16; + $self->_failure_output("$spaces$error\n"); + } + $self->_failure_output($explain) if $explain; + } + } + } + my $files = @$tests; + $self->_output("Files=$files, Tests=$total, $runtime\n"); + my $status = $aggregate->get_status; + $self->_output("Result: $status\n"); +} + +sub _output_summary_failure { + my ( $self, $method, $name, $test, $parser ) = @_; + + # ugly hack. Must rethink this :( + my $output = $method eq 'failed' ? '_failure_output' : '_output'; + + if ( $parser->$method() ) { + $self->_summary_test_header( $test, $parser ); + $self->$output($name); + my @results = $self->_balanced_range( 40, $parser->$method() ); + $self->$output( sprintf "%s\n" => shift @results ); + my $spaces = ' ' x 16; + while (@results) { + $self->$output( sprintf "$spaces%s\n" => shift @results ); + } + } +} + +sub _summary_test_header { + my ( $self, $test, $parser ) = @_; + return if $self->_printed_summary_header; + my $spaces = ' ' x ( $self->_longest - length $test ); + $spaces = ' ' unless $spaces; + my $output = $self->_get_output_method($parser); + $self->$output( + sprintf "$test$spaces(Wstat: %d Tests: %d Failed: %d)\n", + $parser->wait, $parser->tests_run, scalar $parser->failed + ); + $self->_printed_summary_header(1); +} + +sub _output { + my $self = shift; + + print { $self->stdout } @_; +} + +# Use _colorizer delegate to set output color. NOP if we have no delegate +sub _set_colors { + my ( $self, @colors ) = @_; + if ( my $colorizer = $self->_colorizer ) { + my $output_func = $self->{_output_func} ||= sub { + $self->_output(@_); + }; + $colorizer->set_color( $output_func, $_ ) for @colors; + } +} + +sub _failure_output { + my $self = shift; + $self->_set_colors('red'); + my $out = join '', @_; + my $has_newline = chomp $out; + $self->_output($out); + $self->_set_colors('reset'); + $self->_output($/) + if $has_newline; +} + +sub _balanced_range { + my ( $self, $limit, @range ) = @_; + @range = $self->_range(@range); + my $line = ""; + my @lines; + my $curr = 0; + while (@range) { + if ( $curr < $limit ) { + my $range = ( shift @range ) . ", "; + $line .= $range; + $curr += length $range; + } + elsif (@range) { + $line =~ s/, $//; + push @lines => $line; + $line = ''; + $curr = 0; + } + } + if ($line) { + $line =~ s/, $//; + push @lines => $line; + } + return @lines; +} + +sub _range { + my ( $self, @numbers ) = @_; + + # shouldn't be needed, but subclasses might call this + @numbers = sort { $a <=> $b } @numbers; + my ( $min, @range ); + + foreach my $i ( 0 .. $#numbers ) { + my $num = $numbers[$i]; + my $next = $numbers[ $i + 1 ]; + if ( defined $next && $next == $num + 1 ) { + if ( !defined $min ) { + $min = $num; + } + } + elsif ( defined $min ) { + push @range => "$min-$num"; + undef $min; + } + else { + push @range => $num; + } + } + return @range; +} + +sub _get_output_method { + my ( $self, $parser ) = @_; + return $parser->has_problems ? '_failure_output' : '_output'; +} + +1; diff --git a/lib/TAP/Formatter/Console/ParallelSession.pm b/lib/TAP/Formatter/Console/ParallelSession.pm new file mode 100644 index 0000000..b4caac4 --- /dev/null +++ b/lib/TAP/Formatter/Console/ParallelSession.pm @@ -0,0 +1,186 @@ +package TAP::Formatter::Console::ParallelSession; + +use strict; +use File::Spec; +use File::Path; +use TAP::Formatter::Console::Session; +use Carp; + +use constant WIDTH => 72; # Because Eric says +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Formatter::Console::Session); + +my %shared; + +sub _initialize { + my ( $self, $arg_for ) = @_; + + $self->SUPER::_initialize($arg_for); + my $formatter = $self->formatter; + + # Horrid bodge. This creates our shared context per harness. Maybe + # TAP::Harness should give us this? + my $context = $shared{$formatter} ||= $self->_create_shared_context; + push @{ $context->{active} }, $self; + + return $self; +} + +sub _create_shared_context { + my $self = shift; + return { + active => [], + tests => 0, + fails => 0, + }; +} + +sub _need_refresh { + my $self = shift; + my $formatter = $self->formatter; + $shared{$formatter}->{need_refresh}++; +} + +=head1 NAME + +TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel console output + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for L. + +=head1 SYNOPSIS + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C
+ +Output test preamble + +=cut + +sub header { + my $self = shift; + $self->_need_refresh; +} + +sub _refresh { +} + +sub _clear_line { + my $self = shift; + $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); +} + +sub _output_ruler { + my $self = shift; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + + my $context = $shared{$formatter}; + + my $ruler = sprintf( "===( %7d )", $context->{tests} ); + $ruler .= ( '=' x ( WIDTH - length $ruler ) ); + $formatter->_output("\r$ruler"); +} + +=head3 C + + Called by the harness for each line of TAP it receives . + +=cut + +sub result { + my ( $self, $result ) = @_; + my $parser = $self->parser; + my $formatter = $self->formatter; + my $context = $shared{$formatter}; + + $self->_refresh; + + # my $really_quiet = $formatter->really_quiet; + # my $show_count = $self->_should_show_count; + my $planned = $parser->tests_planned; + + if ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + } + + if ( $result->is_test ) { + $context->{tests}++; + + my $test_print_modulus = 1; + my $ceiling = $context->{tests} / 5; + $test_print_modulus *= 2 while $test_print_modulus < $ceiling; + + unless ( $context->{tests} % $test_print_modulus ) { + $self->_output_ruler; + } + } +} + +=head3 C + +=cut + +sub close_test { + my $self = shift; + my $name = $self->name; + my $parser = $self->parser; + my $formatter = $self->formatter; + my $context = $shared{$formatter}; + + unless ( $formatter->really_quiet ) { + $self->_clear_line; + + # my $output = $self->_output_method; + $formatter->_output( + $formatter->_format_name( $self->name ), + ' ' + ); + } + + if ( $parser->has_problems ) { + $self->_output_test_failure($parser); + } + else { + $formatter->_output("ok\n") + unless $formatter->really_quiet; + } + + $self->_output_ruler; + + # $self->SUPER::close_test; + my $active = $context->{active}; + + my @pos = grep { $active->[$_]->name eq $name } 0 .. $#$active; + + die "Can't find myself" unless @pos; + splice @$active, $pos[0], 1; + + $self->_need_refresh; + + unless (@$active) { + + # $self->formatter->_output("\n"); + delete $shared{$formatter}; + } +} + +1; diff --git a/lib/TAP/Formatter/Console/Session.pm b/lib/TAP/Formatter/Console/Session.pm new file mode 100644 index 0000000..5490704 --- /dev/null +++ b/lib/TAP/Formatter/Console/Session.pm @@ -0,0 +1,330 @@ +package TAP::Formatter::Console::Session; + +use strict; +use TAP::Base; + +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Base); + +my @ACCESSOR; + +BEGIN { + + @ACCESSOR = qw( name formatter parser ); + + for my $method (@ACCESSOR) { + no strict 'refs'; + *$method = sub { shift->{$method} }; + } + + my @CLOSURE_BINDING = qw( header result close_test ); + + for my $method (@CLOSURE_BINDING) { + no strict 'refs'; + *$method = sub { + my $self = shift; + return ( $self->{_closures} ||= $self->_closures )->{$method} + ->(@_); + }; + } +} + +=head1 NAME + +TAP::Formatter::Console::Session - Harness output delegate for default console output + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +=head1 DESCRIPTION + +This provides console orientated output formatting for TAP::Harness. + +=head1 SYNOPSIS + +=cut + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + formatter => $self, + ) + my $harness = TAP::Formatter::Console::Session->new( \%args ); + +The constructor returns a new C object. + +=over 4 + +=item * C + +=item * C + +=item * C + +=back + +=cut + +sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize($arg_for); + my %arg_for = %$arg_for; # force a shallow copy + + for my $name (@ACCESSOR) { + $self->{$name} = delete $arg_for{$name}; + } + + if ( my @props = sort keys %arg_for ) { + $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); + } + + return $self; +} + +=head3 C
+ +Output test preamble + +=head3 C + +Called by the harness for each line of TAP it receives. + +=head3 C + +Called to close a test session. + +=cut + +sub _get_output_result { + my $self = shift; + + my @color_map = ( + { test => sub { $_->is_test && !$_->is_ok }, + colors => ['red'], + }, + { test => sub { $_->is_test && $_->has_skip }, + colors => [ + 'white', + 'on_blue' + ], + }, + { test => sub { $_->is_test && $_->has_todo }, + colors => ['yellow'], + }, + ); + + my $formatter = $self->formatter; + my $parser = $self->parser; + + return $formatter->_colorizer + ? sub { + my $result = shift; + for my $col (@color_map) { + local $_ = $result; + if ( $col->{test}->() ) { + $formatter->_set_colors( @{ $col->{colors} } ); + last; + } + } + $formatter->_output( $result->as_string ); + $formatter->_set_colors('reset'); + } + : sub { + $formatter->_output( shift->as_string ); + }; +} + +sub _closures { + my $self = shift; + + my $parser = $self->parser; + my $formatter = $self->formatter; + my $show_count = $self->_should_show_count; + my $pretty = $formatter->_format_name( $self->name ); + + my $really_quiet = $formatter->really_quiet; + my $quiet = $formatter->quiet; + my $verbose = $formatter->verbose; + my $directives = $formatter->directives; + my $failures = $formatter->failures; + + my $output_result = $self->_get_output_result; + + my $output = '_output'; + my $plan = ''; + my $newline_printed = 0; + + my $last_status_printed = 0; + + return { + header => sub { + $formatter->_output($pretty) + unless $really_quiet; + }, + + result => sub { + my $result = shift; + + if ( $result->is_bailout ) { + $formatter->_failure_output( + "Bailout called. Further testing stopped: " + . $result->explanation + . "\n" ); + } + + return if $really_quiet; + + my $is_test = $result->is_test; + + # These are used in close_test - but only if $really_quiet + # is false - so it's safe to only set them here unless that + # relationship changes. + + if ( !$plan ) { + my $planned = $parser->tests_planned || '?'; + $plan = "/$planned "; + } + $output = $formatter->_get_output_method($parser); + + if ( $show_count and $is_test ) { + my $number = $result->number; + my $now = CORE::time; + + # Print status on first number, and roughly once per second + if ( ( $number == 1 ) + || ( $last_status_printed != $now ) ) + { + $formatter->$output("\r$pretty$number$plan"); + $last_status_printed = $now; + } + } + + if (!$quiet + && ( ( $verbose && !$failures ) + || ( $is_test && $failures && !$result->is_ok ) + || ( $result->has_directive && $directives ) ) + ) + { + unless ($newline_printed) { + $formatter->_output("\n"); + $newline_printed = 1; + } + $output_result->($result); + $formatter->_output("\n"); + } + }, + + close_test => sub { + return if $really_quiet; + + if ($show_count) { + my $spaces = ' ' x + length( '.' . $pretty . $plan . $parser->tests_run ); + $formatter->$output("\r$spaces\r$pretty"); + } + + if ( my $skip_all = $parser->skip_all ) { + $formatter->_output("skipped: $skip_all\n"); + } + elsif ( $parser->has_problems ) { + $self->_output_test_failure($parser); + } + else { + my $time_report = ''; + if ( $formatter->timer ) { + my $start_time = $parser->start_time; + my $end_time = $parser->end_time; + if ( defined $start_time and defined $end_time ) { + my $elapsed = $end_time - $start_time; + $time_report + = $self->time_is_hires + ? sprintf( ' %8d ms', $elapsed * 1000 ) + : sprintf( ' %8s s', $elapsed || '<1' ); + } + } + + $formatter->_output("ok$time_report\n"); + } + }, + }; +} + +sub _should_show_count { + + # we need this because if someone tries to redirect the output, it can get + # very garbled from the carriage returns (\r) in the count line. + return !shift->formatter->verbose && -t STDOUT; +} + +sub _output_test_failure { + my ( $self, $parser ) = @_; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + + my $tests_run = $parser->tests_run; + my $tests_planned = $parser->tests_planned; + + my $total + = defined $tests_planned + ? $tests_planned + : $tests_run; + + my $passed = $parser->passed; + + # The total number of fails includes any tests that were planned but + # didn't run + my $failed = $parser->failed + $total - $tests_run; + my $exit = $parser->exit; + + # TODO: $flist isn't used anywhere + # my $flist = join ", " => $formatter->range( $parser->failed ); + + if ( my $exit = $parser->exit ) { + my $wstat = $parser->wait; + my $status = sprintf( "%d (wstat %d, 0x%x)", $exit, $wstat, $wstat ); + $formatter->_failure_output(" Dubious, test returned $status\n"); + } + + if ( $failed == 0 ) { + $formatter->_failure_output( + $total + ? " All $total subtests passed " + : ' No subtests run ' + ); + } + else { + $formatter->_failure_output(" Failed $failed/$total subtests "); + if ( !$total ) { + $formatter->_failure_output("\nNo tests run!"); + } + } + + if ( my $skipped = $parser->skipped ) { + $passed -= $skipped; + my $test = 'subtest' . ( $skipped != 1 ? 's' : '' ); + $formatter->_output( + "\n\t(less $skipped skipped $test: $passed okay)"); + } + + if ( my $failed = $parser->todo_passed ) { + my $test = $failed > 1 ? 'tests' : 'test'; + $formatter->_output( + "\n\t($failed TODO $test unexpectedly succeeded)"); + } + + $formatter->_output("\n"); +} + +1; diff --git a/lib/TAP/Harness.pm b/lib/TAP/Harness.pm new file mode 100644 index 0000000..b792306 --- /dev/null +++ b/lib/TAP/Harness.pm @@ -0,0 +1,666 @@ +package TAP::Harness; + +use strict; +use Carp; + +use File::Spec; +use File::Path; +use IO::Handle; + +use TAP::Base; +use TAP::Parser; +use TAP::Parser::Aggregator; +use TAP::Parser::Multiplexer; + +use vars qw($VERSION @ISA); + +@ISA = qw(TAP::Base); + +=head1 NAME + +TAP::Harness - Run test scripts with statistics + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +$ENV{HARNESS_ACTIVE} = 1; +$ENV{HARNESS_VERSION} = $VERSION; + +END { + + # For VMS. + delete $ENV{HARNESS_ACTIVE}; + delete $ENV{HARNESS_VERSION}; +} + +=head1 DESCRIPTION + +This is a simple test harness which allows tests to be run and results +automatically aggregated and output to STDOUT. + +=head1 SYNOPSIS + + use TAP::Harness; + my $harness = TAP::Harness->new( \%args ); + $harness->runtests(@tests); + +=cut + +my %VALIDATION_FOR; +my @FORMATTER_ARGS; + +sub _error { + my $self = shift; + return $self->{error} unless @_; + $self->{error} = shift; +} + +BEGIN { + + @FORMATTER_ARGS = qw( + directives verbosity timer failures errors stdout color + ); + + %VALIDATION_FOR = ( + lib => sub { + my ( $self, $libs ) = @_; + $libs = [$libs] unless 'ARRAY' eq ref $libs; + + return [ map {"-I$_"} @$libs ]; + }, + switches => sub { shift; shift }, + exec => sub { shift; shift }, + merge => sub { shift; shift }, + formatter_class => sub { shift; shift }, + formatter => sub { shift; shift }, + jobs => sub { shift; shift }, + fork => sub { shift; shift }, + test_args => sub { shift; shift }, + ); + + for my $method ( sort keys %VALIDATION_FOR ) { + no strict 'refs'; + if ( $method eq 'lib' || $method eq 'switches' ) { + *{$method} = sub { + my $self = shift; + unless (@_) { + $self->{$method} ||= []; + return wantarray + ? @{ $self->{$method} } + : $self->{$method}; + } + $self->_croak("Too many arguments to method '$method'") + if @_ > 1; + my $args = shift; + $args = [$args] unless ref $args; + $self->{$method} = $args; + return $self; + }; + } + else { + *{$method} = sub { + my $self = shift; + return $self->{$method} unless @_; + $self->{$method} = shift; + }; + } + } + + for my $method (@FORMATTER_ARGS) { + no strict 'refs'; + *{$method} = sub { + my $self = shift; + return $self->formatter->$method(@_); + }; + } +} + +############################################################################## + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my %args = ( + verbosity => 1, + lib => [ 'lib', 'blib/lib' ], + ) + my $harness = TAP::Harness->new( \%args ); + +The constructor returns a new C object. It accepts an optional +hashref whose allowed keys are: + +=over 4 + +=item * C + +Set the verbosity level: + + 1 verbose Print individual test results to STDOUT. + 0 normal + -1 quiet Suppress some test output (mostly failures + while tests are running). + -2 really quiet Suppress everything but the tests summary. + +=item * C + +Append run time for each test to output. Uses L if available. + +=item * C + +Only show test failures (this is a no-op if C is selected). + +=item * C + +Accepts a scalar value or array ref of scalar values indicating which paths to +allowed libraries should be included if Perl tests are executed. Naturally, +this only makes sense in the context of tests written in Perl. + +=item * C + +Accepts a scalar value or array ref of scalar values indicating which switches +should be included if Perl tests are executed. Naturally, this only makes +sense in the context of tests written in Perl. + +=item * C + +A reference to an C<@INC> style array of arguments to be passed to each +test program. + +=item * C + +Attempt to produce color output. + +=item * C + +Typically, Perl tests are run through this. However, anything which spits out +TAP is fine. You can use this argument to specify the name of the program +(and optional switches) to run your tests with: + + exec => ['/usr/bin/ruby', '-w'] + +=item * C + +If C is true the harness will create parsers that merge STDOUT +and STDERR together for any processes they start. + +=item * C + +The name of the class to use to format output. The default is +L. + +=item * C + +If set C must be an object that is capable of formatting the +TAP output. See L for an example. + +=item * C + +If parse errors are found in the TAP output, a note of this will be made +in the summary report. To see all of the parse errors, set this argument to +true: + + errors => 1 + +=item * C + +If set to a true value, only test results with directives will be displayed. +This overrides other settings such as C or C. + +=item * C + +A filehandle for catching standard output. + +=back + +Any keys for which the value is C will be ignored. + +=cut + +# new supplied by TAP::Base + +{ + my @legal_callback = qw( + parser_args + made_parser + before_runtests + after_runtests + after_test + ); + + sub _initialize { + my ( $self, $arg_for ) = @_; + $arg_for ||= {}; + + $self->SUPER::_initialize( $arg_for, \@legal_callback ); + my %arg_for = %$arg_for; # force a shallow copy + + for my $name ( sort keys %VALIDATION_FOR ) { + my $property = delete $arg_for{$name}; + if ( defined $property ) { + my $validate = $VALIDATION_FOR{$name}; + + my $value = $self->$validate($property); + if ( $self->_error ) { + $self->_croak; + } + $self->$name($value); + } + } + + $self->jobs(1) unless defined $self->jobs; + + unless ( $self->formatter ) { + + $self->formatter_class( my $class = $self->formatter_class + || 'TAP::Formatter::Console' ); + + croak "Bad module name $class" + unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; + + eval "require $class"; + $self->_croak("Can't load $class") if $@; + + # This is a little bodge to preserve legacy behaviour. It's + # pretty horrible that we know which args are destined for + # the formatter. + my %formatter_args = ( jobs => $self->jobs ); + for my $name (@FORMATTER_ARGS) { + if ( defined( my $property = delete $arg_for{$name} ) ) { + $formatter_args{$name} = $property; + } + } + + $self->formatter( $class->new( \%formatter_args ) ); + } + + if ( my @props = sort keys %arg_for ) { + $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); + } + + return $self; + } +} + +############################################################################## + +=head2 Instance Methods + +=head3 C + + $harness->runtests(@tests); + +Accepts and array of C<@tests> to be run. This should generally be the names +of test files, but this is not required. Each element in C<@tests> will be +passed to C as a C. See L for more +information. + +It is possible to provide aliases that will be displayed in place of the +test name by supplying the test as a reference to an array containing +C<< [ $test, $alias ] >>: + + $harness->runtests( [ 't/foo.t', 'Foo Once' ], + [ 't/foo.t', 'Foo Twice' ] ); + +Normally it is an error to attempt to run the same test twice. Aliases +allow you to overcome this limitation by giving each run of the test a +unique name. + +Tests will be run in the order found. + +If the environment variable C is defined it +should name a directory into which a copy of the raw TAP for each test +will be written. TAP is written to files named for each test. +Subdirectories will be created as needed. + +Returns a L containing the test results. + +=cut + +sub runtests { + my ( $self, @tests ) = @_; + + my $aggregate = TAP::Parser::Aggregator->new; + + $self->_make_callback( 'before_runtests', $aggregate ); + $self->aggregate_tests( $aggregate, @tests ); + $self->formatter->summary($aggregate); + $self->_make_callback( 'after_runtests', $aggregate ); + + return $aggregate; +} + +=head3 C + + $harness->aggregate_tests( $aggregate, @tests ); + +Tests will be run in the order found. + +=cut + +sub _after_test { + my ( $self, $aggregate, $test, $parser ) = @_; + + $self->_make_callback( 'after_test', $test, $parser ); + $aggregate->add( $test->[1], $parser ); +} + +sub _aggregate_forked { + my ( $self, $aggregate, @tests ) = @_; + + eval { require Parallel::Iterator }; + + croak "Parallel::Iterator required for --fork option ($@)" + if $@; + + my $iter = Parallel::Iterator::iterate( + { workers => $self->jobs || 0 }, + sub { + my ( $id, $test ) = @_; + + my ( $parser, $session ) = $self->make_parser($test); + + while ( defined( my $result = $parser->next ) ) { + exit 1 if $result->is_bailout; + } + + $self->finish_parser( $parser, $session ); + + # Can't serialise coderefs... + delete $parser->{_iter}; + delete $parser->{_stream}; + delete $parser->{_grammar}; + return $parser; + }, + \@tests + ); + + while ( my ( $id, $parser ) = $iter->() ) { + $self->_after_test( $aggregate, $tests[$id], $parser ); + } + + return; +} + +sub _aggregate_parallel { + my ( $self, $aggregate, @tests ) = @_; + + my $jobs = $self->jobs; + my $mux = TAP::Parser::Multiplexer->new; + + RESULT: { + + # Keep multiplexer topped up + while ( @tests && $mux->parsers < $jobs ) { + my $test = shift @tests; + my ( $parser, $session ) = $self->make_parser($test); + $mux->add( $parser, [ $session, $test ] ); + } + + if ( my ( $parser, $stash, $result ) = $mux->next ) { + my ( $session, $test ) = @$stash; + if ( defined $result ) { + $session->result($result); + exit 1 if $result->is_bailout; + } + else { + + # End of parser. Automatically removed from the mux. + $self->finish_parser( $parser, $session ); + $self->_after_test( $aggregate, $test, $parser ); + } + redo RESULT; + } + } + + return; +} + +sub _aggregate_single { + my ( $self, $aggregate, @tests ) = @_; + + for my $test (@tests) { + my ( $parser, $session ) = $self->make_parser($test); + + while ( defined( my $result = $parser->next ) ) { + $session->result($result); + exit 1 if $result->is_bailout; + } + + $self->finish_parser( $parser, $session ); + $self->_after_test( $aggregate, $test, $parser ); + } + + return; +} + +sub aggregate_tests { + my ( $self, $aggregate, @tests ) = @_; + + my $jobs = $self->jobs; + + my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests; + + # Formatter gets only names + $self->formatter->prepare( map { $_->[1] } @expanded ); + $aggregate->start; + + if ( $self->jobs > 1 ) { + if ( $self->fork ) { + $self->_aggregate_forked( $aggregate, @expanded ); + } + else { + $self->_aggregate_parallel( $aggregate, @expanded ); + } + } + else { + $self->_aggregate_single( $aggregate, @expanded ); + } + + $aggregate->stop; + + return; +} + +=head3 C + +Returns the number of concurrent test runs the harness is handling. For the default +harness this value is always 1. A parallel harness such as L +will override this to return the number of jobs it is handling. + +=head3 C + +If true the harness will attempt to fork and run the parser for each +test in a separate process. Currently this option requires +L to be installed. + +=cut + +############################################################################## + +=head1 SUBCLASSING + +C is designed to be (mostly) easy to subclass. If you don't +like how a particular feature functions, just override the desired methods. + +=head2 Methods + +TODO: This is out of date + +The following methods are ones you may wish to override if you want to +subclass C. + +=head3 C + + $harness->summary( \%args ); + +C prints the summary report after all tests are run. The argument is +a hashref with the following keys: + +=over 4 + +=item * C + +This is created with C<< Benchmark->new >> and it the time the tests started. +You can print a useful summary time, if desired, with: + + $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' )); + +=item * C + +This is an array reference of all test names. To get the L +object for individual tests: + + my $aggregate = $args->{aggregate}; + my $tests = $args->{tests}; + + for my $name ( @$tests ) { + my ($parser) = $aggregate->parsers($test); + ... do something with $parser + } + +This is a bit clunky and will be cleaned up in a later release. + +=back + +=cut + +sub _get_parser_args { + my ( $self, $test ) = @_; + my $test_prog = $test->[0]; + my %args = (); + my @switches; + @switches = $self->lib if $self->lib; + push @switches => $self->switches if $self->switches; + $args{switches} = \@switches; + $args{spool} = $self->_open_spool($test_prog); + $args{merge} = $self->merge; + $args{exec} = $self->exec; + + if ( my $exec = $self->exec ) { + $args{exec} = [ @$exec, $test_prog ]; + } + else { + $args{source} = $test_prog; + } + + if ( defined( my $test_args = $self->test_args ) ) { + $args{test_args} = $test_args; + } + + return \%args; +} + +=head3 C + +Make a new parser and display formatter session. Typically used and/or +overridden in subclasses. + + my ( $parser, $session ) = $harness->make_parser; + + +=cut + +sub make_parser { + my ( $self, $test ) = @_; + + my $args = $self->_get_parser_args($test); + $self->_make_callback( 'parser_args', $args, $test ); + my $parser = TAP::Parser->new($args); + + $self->_make_callback( 'made_parser', $parser, $test ); + my $session = $self->formatter->open_test( $test->[1], $parser ); + + return ( $parser, $session ); +} + +=head3 C + +Terminate use of a parser. Typically used and/or overridden in +subclasses. The parser isn't destroyed as a result of this. + +=cut + +sub finish_parser { + my ( $self, $parser, $session ) = @_; + + $session->close_test; + $self->_close_spool($parser); + + return $parser; +} + +sub _open_spool { + my $self = shift; + my $test = shift; + + if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) { + + my $spool = File::Spec->catfile( $spool_dir, $test ); + + # Make the directory + my ( $vol, $dir, undef ) = File::Spec->splitpath($spool); + my $path = File::Spec->catpath( $vol, $dir, '' ); + eval { mkpath($path) }; + $self->_croak($@) if $@; + + my $spool_handle = IO::Handle->new; + open( $spool_handle, ">$spool" ) + or $self->_croak(" Can't write $spool ( $! ) "); + + return $spool_handle; + } + + return; +} + +sub _close_spool { + my $self = shift; + my ($parser) = @_; + + if ( my $spool_handle = $parser->delete_spool ) { + close($spool_handle) + or $self->_croak(" Error closing TAP spool file( $! ) \n "); + } + + return; +} + +sub _croak { + my ( $self, $message ) = @_; + unless ($message) { + $message = $self->_error; + } + $self->SUPER::_croak($message); + + return; +} + +=head1 REPLACING + +If you like the C utility and L but you want your +own harness, all you need to do is write one and provide C and +C methods. Then you can use the C utility like so: + + prove --harness My::Test::Harness + +Note that while C accepts a list of tests (or things to be +tested), C has a fairly rich set of arguments. You'll probably want +to read over this code carefully to see how all of them are being used. + +=head1 SEE ALSO + +L + +=cut + +1; + +# vim:ts=4:sw=4:et:sta diff --git a/lib/TAP/Parser.pm b/lib/TAP/Parser.pm new file mode 100644 index 0000000..74bb137 --- /dev/null +++ b/lib/TAP/Parser.pm @@ -0,0 +1,1551 @@ +package TAP::Parser; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Base (); +use TAP::Parser::Grammar (); +use TAP::Parser::Result (); +use TAP::Parser::Source (); +use TAP::Parser::Source::Perl (); +use TAP::Parser::Iterator (); +use Carp (); + +@ISA = qw(TAP::Base); + +=head1 NAME + +TAP::Parser - Parse L output + +=head1 VERSION + +Version 3.05 + +=cut + +$VERSION = '3.05'; + +my $DEFAULT_TAP_VERSION = 12; +my $MAX_TAP_VERSION = 13; + +$ENV{TAP_VERSION} = $MAX_TAP_VERSION; + +END { + + # For VMS. + delete $ENV{TAP_VERSION}; +} + +BEGIN { # making accessors + foreach my $method ( + qw( + _stream + _spool + _grammar + exec + exit + is_good_plan + plan + tests_planned + tests_run + wait + version + in_todo + start_time + end_time + skip_all + ) + ) + { + no strict 'refs'; + + # another tiny performance hack + if ( $method =~ /^_/ ) { + *$method = sub { + my $self = shift; + return $self->{$method} unless @_; + + # Trusted methods + unless ( ( ref $self ) =~ /^TAP::Parser/ ) { + Carp::croak("$method() may not be set externally"); + } + + $self->{$method} = shift; + }; + } + else { + *$method = sub { + my $self = shift; + return $self->{$method} unless @_; + $self->{$method} = shift; + }; + } + } +} # done making accessors + +=head1 SYNOPSIS + + use TAP::Parser; + + my $parser = TAP::Parser->new( { source => $source } ); + + while ( my $result = $parser->next ) { + print $result->as_string; + } + +=head1 DESCRIPTION + +C is designed to produce a proper parse of TAP output. For +an example of how to run tests through this module, see the simple +harnesses C. + +There's a wiki dedicated to the Test Anything Protocol: + +L + +It includes the TAP::Parser Cookbook: + +L + +=head1 METHODS + +=head2 Class Methods + +=head3 C + + my $parser = TAP::Parser->new(\%args); + +Returns a new C object. + +The arguments should be a hashref with I of the following keys: + +=over 4 + +=item * C + +This is the preferred method of passing arguments to the constructor. To +determine how to handle the source, the following steps are taken. + +If the source contains a newline, it's assumed to be a string of raw TAP +output. + +If the source is a reference, it's assumed to be something to pass to +the L constructor. This is used +internally and you should not use it. + +Otherwise, the parser does a C<-e> check to see if the source exists. If so, +it attempts to execute the source and read the output as a stream. This is by +far the preferred method of using the parser. + + foreach my $file ( @test_files ) { + my $parser = TAP::Parser->new( { source => $file } ); + # do stuff with the parser + } + +=item * C + +The value should be the complete TAP output. + +=item * C + +If passed an array reference, will attempt to create the iterator by +passing a L object to +L, using the array reference strings as +the command arguments to L: + + exec => [ '/usr/bin/ruby', 't/my_test.rb' ] + +Note that C and C are mutually exclusive. + +=back + +The following keys are optional. + +=over 4 + +=item * C + +If present, each callback corresponding to a given result type will be called +with the result as the argument if the C method is used: + + my %callbacks = ( + test => \&test_callback, + plan => \&plan_callback, + comment => \&comment_callback, + bailout => \&bailout_callback, + unknown => \&unknown_callback, + ); + + my $aggregator = TAP::Parser::Aggregator->new; + foreach my $file ( @test_files ) { + my $parser = TAP::Parser->new( + { + source => $file, + callbacks => \%callbacks, + } + ); + $parser->run; + $aggregator->add( $file, $parser ); + } + +=item * C + +If using a Perl file as a source, optional switches may be passed which will +be used when invoking the perl executable. + + my $parser = TAP::Parser->new( { + source => $test_file, + switches => '-Ilib', + } ); + +=item * C + +Used in conjunction with the C option to supply a reference to +an C<@ARGV> style array of arguments to pass to the test program. + +=item * C + +If passed a filehandle will write a copy of all parsed TAP to that handle. + +=item * C + +If false, STDERR is not captured (though it is 'relayed' to keep it +somewhat synchronized with STDOUT.) + +If true, STDERR and STDOUT are the same filehandle. This may cause +breakage if STDERR contains anything resembling TAP format, but does +allow exact synchronization. + +Subtleties of this behavior may be platform-dependent and may change in +the future. + +=back + +=cut + +# new implementation supplied by TAP::Base + +############################################################################## + +=head2 Instance Methods + +=head3 C + + my $parser = TAP::Parser->new( { source => $file } ); + while ( my $result = $parser->next ) { + print $result->as_string, "\n"; + } + +This method returns the results of the parsing, one result at a time. Note +that it is destructive. You can't rewind and examine previous results. + +If callbacks are used, they will be issued before this call returns. + +Each result returned is a subclass of L. See that +module and related classes for more information on how to use them. + +=cut + +sub next { + my $self = shift; + return ( $self->{_iter} ||= $self->_iter )->(); +} + +############################################################################## + +=head3 C + + $parser->run; + +This method merely runs the parser and parses all of the TAP. + +=cut + +sub run { + my $self = shift; + while ( defined( my $result = $self->next ) ) { + + # do nothing + } +} + +{ + + # of the following, anything beginning with an underscore is strictly + # internal and should not be exposed. + my %initialize = ( + version => $DEFAULT_TAP_VERSION, + plan => '', # the test plan (e.g., 1..3) + tap => '', # the TAP + tests_run => 0, # actual current test numbers + results => [], # TAP parser results + skipped => [], # + todo => [], # + passed => [], # + failed => [], # + actual_failed => [], # how many tests really failed + actual_passed => [], # how many tests really passed + todo_passed => [], # tests which unexpectedly succeed + parse_errors => [], # perfect TAP should have none + ); + + # We seem to have this list hanging around all over the place. We could + # probably get it from somewhere else to avoid the repetition. + my @legal_callback = qw( + test + version + plan + comment + bailout + unknown + yaml + ALL + ELSE + EOF + ); + + sub _initialize { + my ( $self, $arg_for ) = @_; + + # everything here is basically designed to convert any TAP source to a + # stream. + + # Shallow copy + my %args = %{ $arg_for || {} }; + + $self->SUPER::_initialize( \%args, \@legal_callback ); + + my $stream = delete $args{stream}; + my $tap = delete $args{tap}; + my $source = delete $args{source}; + my $exec = delete $args{exec}; + my $merge = delete $args{merge}; + my $spool = delete $args{spool}; + my $switches = delete $args{switches}; + my @test_args = @{ delete $args{test_args} || [] }; + + if ( 1 < grep {defined} $stream, $tap, $source, $exec ) { + $self->_croak( + "You may only choose one of 'exec', 'stream', 'tap' or 'source'" + ); + } + + if ( my @excess = sort keys %args ) { + $self->_croak("Unknown options: @excess"); + } + + if ($tap) { + $stream = TAP::Parser::Iterator->new( [ split "\n" => $tap ] ); + } + elsif ($exec) { + my $source = TAP::Parser::Source->new; + $source->source( [ @$exec, @test_args ] ); + $source->merge($merge); # XXX should just be arguments? + $stream = $source->get_stream; + } + elsif ($source) { + if ( my $ref = ref $source ) { + $stream = TAP::Parser::Iterator->new($source); + } + elsif ( -e $source ) { + + my $perl = TAP::Parser::Source::Perl->new; + + $perl->switches($switches) + if $switches; + + $perl->merge($merge); # XXX args to new()? + + $perl->source( [ $source, @test_args ] ); + + $stream = $perl->get_stream; + } + else { + $self->_croak("Cannot determine source for $source"); + } + } + + unless ($stream) { + $self->_croak('PANIC: could not determine stream'); + } + + while ( my ( $k, $v ) = each %initialize ) { + $self->{$k} = 'ARRAY' eq ref $v ? [] : $v; + } + + $self->_stream($stream); + my $grammar = TAP::Parser::Grammar->new($stream); + $grammar->set_version( $self->version ); + $self->_grammar($grammar); + $self->_spool($spool); + + $self->start_time( $self->get_time ); + + return $self; + } +} + +=head1 INDIVIDUAL RESULTS + +If you've read this far in the docs, you've seen this: + + while ( my $result = $parser->next ) { + print $result->as_string; + } + +Each result returned is a L subclass, referred to as +I. + +=head2 Result types + +Basically, you fetch individual results from the TAP. The six types, with +examples of each, are as follows: + +=over 4 + +=item * Version + + TAP version 12 + +=item * Plan + + 1..42 + +=item * Test + + ok 3 - We should start with some foobar! + +=item * Comment + + # Hope we don't use up the foobar. + +=item * Bailout + + Bail out! We ran out of foobar! + +=item * Unknown + + ... yo, this ain't TAP! ... + +=back + +Each result fetched is a result object of a different type. There are common +methods to each result object and different types may have methods unique to +their type. Sometimes a type method may be overridden in a subclass, but its +use is guaranteed to be identical. + +=head2 Common type methods + +=head3 C + +Returns the type of result, such as C or C. + +=head3 C + +Prints a string representation of the token. This might not be the exact +output, however. Tests will have test numbers added if not present, TODO and +SKIP directives will be capitalized and, in general, things will be cleaned +up. If you need the original text for the token, see the C method. + +=head3 C + +Returns the original line of text which was parsed. + +=head3 C + +Indicates whether or not this is the test plan line. + +=head3 C + +Indicates whether or not this is a test line. + +=head3 C + +Indicates whether or not this is a comment. Comments will generally only +appear in the TAP stream if STDERR is merged to STDOUT. See the +C option. + +=head3 C + +Indicates whether or not this is bailout line. + +=head3 C + +Indicates whether or not the current item is a YAML block. + +=head3 C + +Indicates whether or not the current line could be parsed. + +=head3 C + + if ( $result->is_ok ) { ... } + +Reports whether or not a given result has passed. Anything which is B a +test result returns true. This is merely provided as a convenient shortcut +which allows you to do this: + + my $parser = TAP::Parser->new( { source => $source } ); + while ( my $result = $parser->next ) { + # only print failing results + print $result->as_string unless $result->is_ok; + } + +=head2 C methods + + if ( $result->is_plan ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_plan ) { + print $result->plan; + } + +This is merely a synonym for C. + +=head3 C + + my $planned = $result->tests_planned; + +Returns the number of tests planned. For example, a plan of C<1..17> will +cause this method to return '17'. + +=head3 C + + my $directive = $result->directive; + +If a SKIP directive is included with the plan, this method will return it. + + 1..0 # SKIP: why bother? + +=head3 C + + my $explanation = $result->explanation; + +If a SKIP directive was included with the plan, this method will return the +explanation, if any. + +=head2 C methods + + if ( $result->is_comment ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_comment ) { + my $comment = $result->comment; + print "I have something to say: $comment"; + } + +=head2 C methods + + if ( $result->is_bailout ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + if ( $result->is_bailout ) { + my $explanation = $result->explanation; + print "We bailed out because ($explanation)"; + } + +If, and only if, a token is a bailout token, you can get an "explanation" via +this method. The explanation is the text after the mystical "Bail out!" words +which appear in the tap output. + +=head2 C methods + + if ( $result->is_unknown ) { ... } + +There are no unique methods for unknown results. + +=head2 C methods + + if ( $result->is_test ) { ... } + +If the above evaluates as true, the following methods will be available on the +C<$result> object. + +=head3 C + + my $ok = $result->ok; + +Returns the literal text of the C or C status. + +=head3 C + + my $test_number = $result->number; + +Returns the number of the test, even if the original TAP output did not supply +that number. + +=head3 C + + my $description = $result->description; + +Returns the description of the test, if any. This is the portion after the +test number but before the directive. + +=head3 C + + my $directive = $result->directive; + +Returns either C or C if either directive was present for a test +line. + +=head3 C + + my $explanation = $result->explanation; + +If a test had either a C or C directive, this method will return +the accompanying explantion, if present. + + not ok 17 - 'Pigs can fly' # TODO not enough acid + +For the above line, the explanation is I. + +=head3 C + + if ( $result->is_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed. Remember +that for TODO tests, the test always passes. + +B this was formerly C. The latter method is deprecated and +will issue a warning. + +=head3 C + + if ( $result->is_actual_ok ) { ... } + +Returns a boolean value indicating whether or not the test passed, regardless +of its TODO status. + +B this was formerly C. The latter method is deprecated +and will issue a warning. + +=head3 C + + if ( $test->is_unplanned ) { ... } + +If a test number is greater than the number of planned tests, this method will +return true. Unplanned tests will I return false for C, +regardless of whether or not the test C (see +L for more information about this). + +=head3 C + + if ( $result->has_skip ) { ... } + +Returns a boolean value indicating whether or not this test had a SKIP +directive. + +=head3 C + + if ( $result->has_todo ) { ... } + +Returns a boolean value indicating whether or not this test had a TODO +directive. + +Note that TODO tests I pass. If you need to know whether or not +they really passed, check the C method. + +=head3 C + + if ( $parser->in_todo ) { ... } + +True while the most recent result was a TODO. Becomes true before the +TODO result is returned and stays true until just before the next non- +TODO test is returned. + +=head1 TOTAL RESULTS + +After parsing the TAP, there are many methods available to let you dig through +the results and determine what is meaningful to you. + +=head2 Individual Results + +These results refer to individual tests which are run. + +=head3 C + + my @passed = $parser->passed; # the test numbers which passed + my $passed = $parser->passed; # the number of tests which passed + +This method lets you know which (or how many) tests passed. If a test failed +but had a TODO directive, it will be counted as a passed test. + +=cut + +sub passed { @{ shift->{passed} } } + +=head3 C + + my @failed = $parser->failed; # the test numbers which failed + my $failed = $parser->failed; # the number of tests which failed + +This method lets you know which (or how many) tests failed. If a test passed +but had a TODO directive, it will B be counted as a failed test. + +=cut + +sub failed { @{ shift->{failed} } } + +=head3 C + + # the test numbers which actually passed + my @actual_passed = $parser->actual_passed; + + # the number of tests which actually passed + my $actual_passed = $parser->actual_passed; + +This method lets you know which (or how many) tests actually passed, +regardless of whether or not a TODO directive was found. + +=cut + +sub actual_passed { @{ shift->{actual_passed} } } +*actual_ok = \&actual_passed; + +=head3 C + +This method is a synonym for C. + +=head3 C + + # the test numbers which actually failed + my @actual_failed = $parser->actual_failed; + + # the number of tests which actually failed + my $actual_failed = $parser->actual_failed; + +This method lets you know which (or how many) tests actually failed, +regardless of whether or not a TODO directive was found. + +=cut + +sub actual_failed { @{ shift->{actual_failed} } } + +############################################################################## + +=head3 C + + my @todo = $parser->todo; # the test numbers with todo directives + my $todo = $parser->todo; # the number of tests with todo directives + +This method lets you know which (or how many) tests had TODO directives. + +=cut + +sub todo { @{ shift->{todo} } } + +=head3 C + + # the test numbers which unexpectedly succeeded + my @todo_passed = $parser->todo_passed; + + # the number of tests which unexpectedly succeeded + my $todo_passed = $parser->todo_passed; + +This method lets you know which (or how many) tests actually passed but were +declared as "TODO" tests. + +=cut + +sub todo_passed { @{ shift->{todo_passed} } } + +############################################################################## + +=head3 C + + # deprecated in favor of 'todo_passed'. This method was horribly misnamed. + +This was a badly misnamed method. It indicates which TODO tests unexpectedly +succeeded. Will now issue a warning and call C. + +=cut + +sub todo_failed { + warn + '"todo_failed" is deprecated. Please use "todo_passed". See the docs.'; + goto &todo_passed; +} + +=head3 C + + my @skipped = $parser->skipped; # the test numbers with SKIP directives + my $skipped = $parser->skipped; # the number of tests with SKIP directives + +This method lets you know which (or how many) tests had SKIP directives. + +=cut + +sub skipped { @{ shift->{skipped} } } + +=head2 Summary Results + +These results are "meta" information about the total results of an individual +test program. + +=head3 C + + my $plan = $parser->plan; + +Returns the test plan, if found. + +=head3 C + +Deprecated. Use C instead. + +=cut + +sub good_plan { + warn 'good_plan() is deprecated. Please use "is_good_plan()"'; + goto &is_good_plan; +} + +############################################################################## + +=head3 C + + if ( $parser->is_good_plan ) { ... } + +Returns a boolean value indicating whether or not the number of tests planned +matches the number of tests run. + +B this was formerly C. The latter method is deprecated and +will issue a warning. + +And since we're on that subject ... + +=head3 C + + print $parser->tests_planned; + +Returns the number of tests planned, according to the plan. For example, a +plan of '1..17' will mean that 17 tests were planned. + +=head3 C + + print $parser->tests_run; + +Returns the number of tests which actually were run. Hopefully this will +match the number of C<< $parser->tests_planned >>. + +=head3 C + +Returns a true value (actually the reason for skipping) if all tests +were skipped. + +=head3 C + +Returns the time when the Parser was created. + +=head3 C + +Returns the time when the end of TAP input was seen. + +=head3 C + + if ( $parser->has_problems ) { + ... + } + +This is a 'catch-all' method which returns true if any tests have currently +failed, any TODO tests unexpectedly succeeded, or any parse errors occurred. + +=cut + +sub has_problems { + my $self = shift; + return $self->failed + || $self->parse_errors + || $self->wait + || $self->exit; +} + +=head3 C + + $parser->version; + +Once the parser is done, this will return the version number for the +parsed TAP. Version numbers were introduced with TAP version 13 so if no +version number is found version 12 is assumed. + +=head3 C + + $parser->exit; + +Once the parser is done, this will return the exit status. If the parser ran +an executable, it returns the exit status of the executable. + +=head3 C + + $parser->wait; + +Once the parser is done, this will return the wait status. If the parser ran +an executable, it returns the wait status of the executable. Otherwise, this +mererely returns the C status. + +=head3 C + + my @errors = $parser->parse_errors; # the parser errors + my $errors = $parser->parse_errors; # the number of parser_errors + +Fortunately, all TAP output is perfect. In the event that it is not, this +method will return parser errors. Note that a junk line which the parser does +not recognize is C an error. This allows this parser to handle future +versions of TAP. The following are all TAP errors reported by the parser: + +=over 4 + +=item * Misplaced plan + +The plan (for example, '1..5'), must only come at the beginning or end of the +TAP output. + +=item * No plan + +Gotta have a plan! + +=item * More than one plan + + 1..3 + ok 1 - input file opened + not ok 2 - first line of the input valid # todo some data + ok 3 read the rest of the file + 1..3 + +Right. Very funny. Don't do that. + +=item * Test numbers out of sequence + + 1..3 + ok 1 - input file opened + not ok 2 - first line of the input valid # todo some data + ok 2 read the rest of the file + +That last test line above should have the number '3' instead of '2'. + +Note that it's perfectly acceptable for some lines to have test numbers and +others to not have them. However, when a test number is found, it must be in +sequence. The following is also an error: + + 1..3 + ok 1 - input file opened + not ok - first line of the input valid # todo some data + ok 2 read the rest of the file + +But this is not: + + 1..3 + ok - input file opened + not ok - first line of the input valid # todo some data + ok 3 read the rest of the file + +=back + +=cut + +sub parse_errors { @{ shift->{parse_errors} } } + +sub _add_error { + my ( $self, $error ) = @_; + push @{ $self->{parse_errors} } => $error; + return $self; +} + +sub _make_state_table { + my $self = shift; + my %states; + my %planned_todo = (); + + # These transitions are defaults for all states + my %state_globals = ( + comment => {}, + bailout => {}, + version => { + act => sub { + my ($version) = @_; + $self->_add_error( + 'If TAP version is present it must be the first line of output' + ); + }, + }, + ); + + # Provides default elements for transitions + my %state_defaults = ( + plan => { + act => sub { + my ($plan) = @_; + $self->tests_planned( $plan->tests_planned ); + $self->plan( $plan->plan ); + if ( $plan->has_skip ) { + $self->skip_all( $plan->explanation + || '(no reason given)' ); + } + + $planned_todo{$_}++ for @{ $plan->todo_list }; + }, + }, + test => { + act => sub { + my ($test) = @_; + + my ( $number, $tests_run ) + = ( $test->number, ++$self->{tests_run} ); + + # Fake TODO state + if ( defined $number && delete $planned_todo{$number} ) { + $test->set_directive('TODO'); + } + + my $has_todo = $test->has_todo; + + $self->in_todo($has_todo); + if ( defined( my $tests_planned = $self->tests_planned ) ) { + if ( $tests_run > $tests_planned ) { + $test->is_unplanned(1); + } + } + + if ($number) { + if ( $number != $tests_run ) { + my $count = $tests_run; + $self->_add_error( "Tests out of sequence. Found " + . "($number) but expected ($count)" ); + } + } + else { + $test->_number( $number = $tests_run ); + } + + push @{ $self->{todo} } => $number if $has_todo; + push @{ $self->{todo_passed} } => $number + if $test->todo_passed; + push @{ $self->{skipped} } => $number + if $test->has_skip; + + push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } => + $number; + push @{ + $self->{ + $test->is_actual_ok + ? 'actual_passed' + : 'actual_failed' + } + } => $number; + }, + }, + yaml => { + act => sub { }, + }, + ); + + # Each state contains a hash the keys of which match a token type. For + # each token + # type there may be: + # act A coderef to run + # goto The new state to move to. Stay in this state if + # missing + # continue Goto the new state and run the new state for the + # current token + %states = ( + INIT => { + version => { + act => sub { + my ($version) = @_; + my $ver_num = $version->version; + if ( $ver_num <= $DEFAULT_TAP_VERSION ) { + my $ver_min = $DEFAULT_TAP_VERSION + 1; + $self->_add_error( + "Explicit TAP version must be at least " + . "$ver_min. Got version $ver_num" ); + $ver_num = $DEFAULT_TAP_VERSION; + } + if ( $ver_num > $MAX_TAP_VERSION ) { + $self->_add_error( + "TAP specified version $ver_num but " + . "we don't know about versions later " + . "than $MAX_TAP_VERSION" ); + $ver_num = $MAX_TAP_VERSION; + } + $self->version($ver_num); + $self->_grammar->set_version($ver_num); + }, + goto => 'PLAN' + }, + plan => { goto => 'PLANNED' }, + test => { goto => 'UNPLANNED' }, + }, + PLAN => { + plan => { goto => 'PLANNED' }, + test => { goto => 'UNPLANNED' }, + }, + PLANNED => { + test => { goto => 'PLANNED_AFTER_TEST' }, + plan => { + act => sub { + my ($version) = @_; + $self->_add_error( + 'More than one plan found in TAP output'); + }, + }, + }, + PLANNED_AFTER_TEST => { + test => { goto => 'PLANNED_AFTER_TEST' }, + plan => { act => sub { }, continue => 'PLANNED' }, + yaml => { goto => 'PLANNED' }, + }, + GOT_PLAN => { + test => { + act => sub { + my ($plan) = @_; + my $line = $self->plan; + $self->_add_error( + "Plan ($line) must be at the beginning " + . "or end of the TAP output" ); + $self->is_good_plan(0); + }, + continue => 'PLANNED' + }, + plan => { continue => 'PLANNED' }, + }, + UNPLANNED => { + test => { goto => 'UNPLANNED_AFTER_TEST' }, + plan => { goto => 'GOT_PLAN' }, + }, + UNPLANNED_AFTER_TEST => { + test => { act => sub { }, continue => 'UNPLANNED' }, + plan => { act => sub { }, continue => 'UNPLANNED' }, + yaml => { goto => 'PLANNED' }, + }, + ); + + # Apply globals and defaults to state table + for my $name ( sort keys %states ) { + + # Merge with globals + my $st = { %state_globals, %{ $states{$name} } }; + + # Add defaults + for my $next ( sort keys %{$st} ) { + if ( my $default = $state_defaults{$next} ) { + for my $def ( sort keys %{$default} ) { + $st->{$next}->{$def} ||= $default->{$def}; + } + } + } + + # Stuff back in table + $states{$name} = $st; + } + + return \%states; +} + +=head3 C + +Get an a list of file handles which can be passed to C