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
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
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
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
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
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
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
'abigail' => 'Abigail <abigail@abigail.be>',
'ams' => 'Abhijit Menon-Sen <ams@cpan.org>',
'andk' => 'Andreas J. Koenig <andk@cpan.org>',
+ 'andya' => 'Andy Armstrong <andya@cpan.org>',
'arandal' => 'Allison Randal <allison@perl.org>',
'audreyt' => 'Audrey Tang <cpan@audreyt.org>',
'avar' => 'Ævar Arnfjörð Bjarmason <avar@cpan.org>',
'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,
},
--- /dev/null
+package TAP::Base;
+
+use strict;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness>
+
+=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<TAP::Base> provides callback management.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=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<callback>
+
+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<get_time>
+
+Return the current time using Time::HiRes if available.
+
+=cut
+
+sub get_time { return time() }
+
+=head3 C<time_is_hires>
+
+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;
--- /dev/null
+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<experimental>. 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<TAP::Harness>, 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<Term::ANSIColor> cannot be found (or L<Win32::Console> 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<new>
+
+The constructor returns a new C<TAP::Formatter::Color> object. If
+L<Term::ANSIColor> 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<can_color>
+
+ 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_color>
+
+Set the output color.
+
+=cut
+
+1;
--- /dev/null
+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<new>
+
+ my %args = (
+ verbose => 1,
+ )
+ my $harness = TAP::Formatter::Console->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console> object. If
+a L<TAP::Harness> is created with no C<formatter> a
+C<TAP::Formatter::Console> 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<verbosity>
+
+Set the verbosity level.
+
+=item * C<verbose>
+
+Printing individual test results to STDOUT.
+
+=item * C<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<quiet>
+
+Suppressing some test output (mostly failures while tests are running).
+
+=item * C<really_quiet>
+
+Suppressing everything but the tests summary.
+
+=item * C<silent>
+
+Suppressing all output.
+
+=item * C<errors>
+
+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<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=item * C<color>
+
+If defined specifies whether color output is desired. If C<color> 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<jobs>
+
+The number of concurrent jobs this formatter will handle.
+
+=back
+
+Any keys for which the value is C<undef> will be ignored.
+
+=cut
+
+# new supplied by TAP::Base
+
+=head3 C<prepare>
+
+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<open_test>
+
+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<summary>
+
+ $harness->summary( $aggregate );
+
+C<summary> 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;
--- /dev/null
+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<TAP::Harness::Parallel>.
+
+=head1 SYNOPSIS
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<header>
+
+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<result>
+
+ 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<close_test>
+
+=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;
--- /dev/null
+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<new>
+
+ my %args = (
+ formatter => $self,
+ )
+ my $harness = TAP::Formatter::Console::Session->new( \%args );
+
+The constructor returns a new C<TAP::Formatter::Console::Session> object.
+
+=over 4
+
+=item * C<formatter>
+
+=item * C<parser>
+
+=item * C<name>
+
+=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<header>
+
+Output test preamble
+
+=head3 C<result>
+
+Called by the harness for each line of TAP it receives.
+
+=head3 C<close_test>
+
+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;
--- /dev/null
+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<new>
+
+ my %args = (
+ verbosity => 1,
+ lib => [ 'lib', 'blib/lib' ],
+ )
+ my $harness = TAP::Harness->new( \%args );
+
+The constructor returns a new C<TAP::Harness> object. It accepts an optional
+hashref whose allowed keys are:
+
+=over 4
+
+=item * C<verbosity>
+
+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<timer>
+
+Append run time for each test to output. Uses L<Time::HiRes> if available.
+
+=item * C<failures>
+
+Only show test failures (this is a no-op if C<verbose> is selected).
+
+=item * C<lib>
+
+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<switches>
+
+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<test_args>
+
+A reference to an C<@INC> style array of arguments to be passed to each
+test program.
+
+=item * C<color>
+
+Attempt to produce color output.
+
+=item * C<exec>
+
+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<merge>
+
+If C<merge> is true the harness will create parsers that merge STDOUT
+and STDERR together for any processes they start.
+
+=item * C<formatter_class>
+
+The name of the class to use to format output. The default is
+L<TAP::Formatter::Console>.
+
+=item * C<formatter>
+
+If set C<formatter> must be an object that is capable of formatting the
+TAP output. See L<TAP::Formatter::Console> for an example.
+
+=item * C<errors>
+
+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<directives>
+
+If set to a true value, only test results with directives will be displayed.
+This overrides other settings such as C<verbose> or C<failures>.
+
+=item * C<stdout>
+
+A filehandle for catching standard output.
+
+=back
+
+Any keys for which the value is C<undef> 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<runtests>
+
+ $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<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> 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<PERL_TEST_HARNESS_DUMP_TAP> 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<TAP::Parser::Aggregator> 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<aggregate_tests>
+
+ $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<jobs>
+
+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<TAP::Harness::Parallel>
+will override this to return the number of jobs it is handling.
+
+=head3 C<fork>
+
+If true the harness will attempt to fork and run the parser for each
+test in a separate process. Currently this option requires
+L<Parallel::Iterator> to be installed.
+
+=cut
+
+##############################################################################
+
+=head1 SUBCLASSING
+
+C<TAP::Harness> 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<TAP::Harness>.
+
+=head3 C<summary>
+
+ $harness->summary( \%args );
+
+C<summary> prints the summary report after all tests are run. The argument is
+a hashref with the following keys:
+
+=over 4
+
+=item * C<start>
+
+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<tests>
+
+This is an array reference of all test names. To get the L<TAP::Parser>
+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_parser>
+
+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<finish_parser>
+
+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<prove> utility and L<TAP::Parser> but you want your
+own harness, all you need to do is write one and provide C<new> and
+C<runtests> methods. Then you can use the C<prove> utility like so:
+
+ prove --harness My::Test::Harness
+
+Note that while C<prove> accepts a list of tests (or things to be
+tested), C<new> 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<Test::Harness>
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+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<TAP|Test::Harness::TAP> 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<TAP::Parser> 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<examples/>.
+
+There's a wiki dedicated to the Test Anything Protocol:
+
+L<http://testanything.org>
+
+It includes the TAP::Parser Cookbook:
+
+L<http://testanything.org/wiki/index.php/TAP::Parser_Cookbook>
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $parser = TAP::Parser->new(\%args);
+
+Returns a new C<TAP::Parser> object.
+
+The arguments should be a hashref with I<one> of the following keys:
+
+=over 4
+
+=item * C<source>
+
+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<TAP::Parser::Iterator::Stream> 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<tap>
+
+The value should be the complete TAP output.
+
+=item * C<exec>
+
+If passed an array reference, will attempt to create the iterator by
+passing a L<TAP::Parser::Source> object to
+L<TAP::Parser::Iterator::Source>, using the array reference strings as
+the command arguments to L<IPC::Open3::open3|IPC::Open3>:
+
+ exec => [ '/usr/bin/ruby', 't/my_test.rb' ]
+
+Note that C<source> and C<exec> are mutually exclusive.
+
+=back
+
+The following keys are optional.
+
+=over 4
+
+=item * C<callback>
+
+If present, each callback corresponding to a given result type will be called
+with the result as the argument if the C<run> 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<switches>
+
+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<test_args>
+
+Used in conjunction with the C<source> option to supply a reference to
+an C<@ARGV> style array of arguments to pass to the test program.
+
+=item * C<spool>
+
+If passed a filehandle will write a copy of all parsed TAP to that handle.
+
+=item * C<merge>
+
+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<next>
+
+ 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<TAP::Parser::Result>. 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<run>
+
+ $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<TAP::Parser::Result> subclass, referred to as
+I<result types>.
+
+=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<type>
+
+Returns the type of result, such as C<comment> or C<test>.
+
+=head3 C<as_string>
+
+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<raw> method.
+
+=head3 C<raw>
+
+Returns the original line of text which was parsed.
+
+=head3 C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+=head3 C<is_test>
+
+Indicates whether or not this is a test line.
+
+=head3 C<is_comment>
+
+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<merge> option.
+
+=head3 C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+=head3 C<is_yaml>
+
+Indicates whether or not the current item is a YAML block.
+
+=head3 C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> 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<plan> methods
+
+ if ( $result->is_plan ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=head3 C<tests_planned>
+
+ 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<directive>
+
+ 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<explanation>
+
+ my $explanation = $result->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=head2 C<commment> methods
+
+ if ( $result->is_comment ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=head2 C<bailout> methods
+
+ if ( $result->is_bailout ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<explanation>
+
+ 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<unknown> methods
+
+ if ( $result->is_unknown ) { ... }
+
+There are no unique methods for unknown results.
+
+=head2 C<test> methods
+
+ if ( $result->is_test ) { ... }
+
+If the above evaluates as true, the following methods will be available on the
+C<$result> object.
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=head3 C<description>
+
+ 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<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> 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<not enough acid>.
+
+=head3 C<is_ok>
+
+ 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<Note:> this was formerly C<passed>. The latter method is deprecated and
+will issue a warning.
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+B<Note:> this was formerly C<actual_passed>. The latter method is deprecated
+and will issue a warning.
+
+=head3 C<is_unplanned>
+
+ 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<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo> (see
+L<TAP::Parser::Result::Test> for more information about this).
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test had a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test had a TODO
+directive.
+
+Note that TODO tests I<always> pass. If you need to know whether or not
+they really passed, check the C<is_actual_ok> method.
+
+=head3 C<in_todo>
+
+ 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<passed>
+
+ 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<failed>
+
+ 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<NOT> be counted as a failed test.
+
+=cut
+
+sub failed { @{ shift->{failed} } }
+
+=head3 C<actual_passed>
+
+ # 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<actual_ok>
+
+This method is a synonym for C<actual_passed>.
+
+=head3 C<actual_failed>
+
+ # 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<todo>
+
+ 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<todo_passed>
+
+ # 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<todo_failed>
+
+ # 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<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+=head3 C<skipped>
+
+ 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<plan>
+
+ my $plan = $parser->plan;
+
+Returns the test plan, if found.
+
+=head3 C<good_plan>
+
+Deprecated. Use C<is_good_plan> instead.
+
+=cut
+
+sub good_plan {
+ warn 'good_plan() is deprecated. Please use "is_good_plan()"';
+ goto &is_good_plan;
+}
+
+##############################################################################
+
+=head3 C<is_good_plan>
+
+ 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<Note:> this was formerly C<good_plan>. The latter method is deprecated and
+will issue a warning.
+
+And since we're on that subject ...
+
+=head3 C<tests_planned>
+
+ 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<tests_run>
+
+ 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<skip_all>
+
+Returns a true value (actually the reason for skipping) if all tests
+were skipped.
+
+=head3 C<start_time>
+
+Returns the time when the Parser was created.
+
+=head3 C<end_time>
+
+Returns the time when the end of TAP input was seen.
+
+=head3 C<has_problems>
+
+ 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<version>
+
+ $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<exit>
+
+ $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<wait>
+
+ $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<exit> status.
+
+=head3 C<parse_errors>
+
+ 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<not> 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_select_handles>
+
+Get an a list of file handles which can be passed to C<select> to
+determine the readiness of this parser.
+
+=cut
+
+sub get_select_handles { shift->_stream->get_select_handles }
+
+sub _iter {
+ my $self = shift;
+ my $stream = $self->_stream;
+ my $spool = $self->_spool;
+ my $grammar = $self->_grammar;
+ my $state = 'INIT';
+ my $state_table = $self->_make_state_table;
+
+ # Make next_state closure
+ my $next_state = sub {
+ my $token = shift;
+ my $type = $token->type;
+ my $count = 1;
+ TRANS: {
+ my $state_spec = $state_table->{$state}
+ or die "Illegal state: $state";
+
+ if ( my $next = $state_spec->{$type} ) {
+ if ( my $act = $next->{act} ) {
+ $act->($token);
+ }
+ if ( my $cont = $next->{continue} ) {
+ $state = $cont;
+ redo TRANS;
+ }
+ elsif ( my $goto = $next->{goto} ) {
+ $state = $goto;
+ }
+ }
+ }
+ return $token;
+ };
+
+ # Handle end of stream - which means either pop a block or finish
+ my $end_handler = sub {
+ $self->exit( $stream->exit );
+ $self->wait( $stream->wait );
+ $self->_finish;
+ return;
+ };
+
+ # Finally make the closure that we return. For performance reasons
+ # there are two versions of the returned function: one that handles
+ # callbacks and one that does not.
+ if ( $self->_has_callbacks ) {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ if ( my $code = $self->_callback_for( $result->type ) ) {
+ $_->($result) for @{$code};
+ }
+ else {
+ $self->_make_callback( 'ELSE', $result );
+ }
+
+ $self->_make_callback( 'ALL', $result );
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ $self->_make_callback( 'EOF', $result )
+ unless defined $result;
+ }
+
+ return $result;
+ };
+ } # _has_callbacks
+ else {
+ return sub {
+ my $result = eval { $grammar->tokenize };
+ $self->_add_error($@) if $@;
+
+ if ( defined $result ) {
+ $result = $next_state->($result);
+
+ # Echo TAP to spool file
+ print {$spool} $result->raw, "\n" if $spool;
+ }
+ else {
+ $result = $end_handler->();
+ }
+
+ return $result;
+ };
+ } # no callbacks
+}
+
+sub _finish {
+ my $self = shift;
+
+ $self->end_time( $self->get_time );
+
+ # sanity checks
+ if ( !$self->plan ) {
+ $self->_add_error('No plan found in TAP output');
+ }
+ else {
+ $self->is_good_plan(1) unless defined $self->is_good_plan;
+ }
+ if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
+ $self->is_good_plan(0);
+ if ( defined( my $planned = $self->tests_planned ) ) {
+ my $ran = $self->tests_run;
+ $self->_add_error(
+ "Bad plan. You planned $planned tests but ran $ran.");
+ }
+ }
+ if ( $self->tests_run != ( $self->passed + $self->failed ) ) {
+
+ # this should never happen
+ my $actual = $self->tests_run;
+ my $passed = $self->passed;
+ my $failed = $self->failed;
+ $self->_croak( "Panic: planned test count ($actual) did not equal "
+ . "sum of passed ($passed) and failed ($failed) tests!" );
+ }
+
+ $self->is_good_plan(0) unless defined $self->is_good_plan;
+ return $self;
+}
+
+=head3 C<delete_spool>
+
+Delete and return the spool.
+
+ my $fh = $parser->delete_spool;
+
+=cut
+
+sub delete_spool {
+ my $self = shift;
+
+ return delete $self->{_spool};
+}
+
+##############################################################################
+
+=head1 CALLBACKS
+
+As mentioned earlier, a "callback" key may be added to the
+C<TAP::Parser> constructor. If present, each callback corresponding to a
+given result type will be called with the result as the argument if the
+C<run> method is used. The callback is expected to be a subroutine
+reference (or anonymous subroutine) which is invoked with the parser
+result as its argument.
+
+ 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 );
+ }
+
+Callbacks may also be added like this:
+
+ $parser->callback( test => \&test_callback );
+ $parser->callback( plan => \&plan_callback );
+
+The following keys allowed for callbacks. These keys are case-sensitive.
+
+=over 4
+
+=item * C<test>
+
+Invoked if C<< $result->is_test >> returns true.
+
+=item * C<version>
+
+Invoked if C<< $result->is_version >> returns true.
+
+=item * C<plan>
+
+Invoked if C<< $result->is_plan >> returns true.
+
+=item * C<comment>
+
+Invoked if C<< $result->is_comment >> returns true.
+
+=item * C<bailout>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<yaml>
+
+Invoked if C<< $result->is_yaml >> returns true.
+
+=item * C<unknown>
+
+Invoked if C<< $result->is_unknown >> returns true.
+
+=item * C<ELSE>
+
+If a result does not have a callback defined for it, this callback will
+be invoked. Thus, if all of the previous result types are specified as
+callbacks, this callback will I<never> be invoked.
+
+=item * C<ALL>
+
+This callback will always be invoked and this will happen for each
+result after one of the above callbacks is invoked. For example, if
+L<Term::ANSIColor> is loaded, you could use the following to color your
+test output:
+
+ my %callbacks = (
+ test => sub {
+ my $test = shift;
+ if ( $test->is_ok && not $test->directive ) {
+ # normal passing test
+ print color 'green';
+ }
+ elsif ( !$test->is_ok ) { # even if it's TODO
+ print color 'white on_red';
+ }
+ elsif ( $test->has_skip ) {
+ print color 'white on_blue';
+
+ }
+ elsif ( $test->has_todo ) {
+ print color 'white';
+ }
+ },
+ ELSE => sub {
+ # plan, comment, and so on (anything which isn't a test line)
+ print color 'black on_white';
+ },
+ ALL => sub {
+ # now print them
+ print shift->as_string;
+ print color 'reset';
+ print "\n";
+ },
+ );
+
+=item * C<EOF>
+
+Invoked when there are no more lines to be parsed. Since there is no
+accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
+passed instead.
+
+=back
+
+=head1 TAP GRAMMAR
+
+If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.
+
+=head1 BACKWARDS COMPATABILITY
+
+The Perl-QA list attempted to ensure backwards compatability with
+L<Test::Harness>. However, there are some minor differences.
+
+=head2 Differences
+
+=over 4
+
+=item * TODO plans
+
+A little-known feature of L<Test::Harness> is that it supported TODO
+lists in the plan:
+
+ 1..2 todo 2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated
+
+Under L<Test::Harness>, test number 2 would I<pass> because it was
+listed as a TODO test on the plan line. However, we are not aware of
+anyone actually using this feature and hard-coding test numbers is
+discouraged because it's very easy to add a test and break the test
+number sequence. This makes test suites very fragile. Instead, the
+following should be used:
+
+ 1..2
+ ok 1 - We have liftoff
+ not ok 2 - Anti-gravity device activated # TODO
+
+=item * 'Missing' tests
+
+It rarely happens, but sometimes a harness might encounter
+'missing tests:
+
+ ok 1
+ ok 2
+ ok 15
+ ok 16
+ ok 17
+
+L<Test::Harness> would report tests 3-14 as having failed. For the
+C<TAP::Parser>, these tests are not considered failed because they've
+never run. They're reported as parse failures (tests out of sequence).
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+All of the following have helped. Bug reports, patches, (im)moral
+support, or just words of encouragement have all been forthcoming.
+
+=over 4
+
+=item * Michael Schwern
+
+=item * Andy Lester
+
+=item * chromatic
+
+=item * GEOFFR
+
+=item * Shlomi Fish
+
+=item * Torsten Schoenfeld
+
+=item * Jerry Gay
+
+=item * Aristotle
+
+=item * Adam Kennedy
+
+=item * Yves Orton
+
+=item * Adrian Howard
+
+=item * Sean & Lil
+
+=item * Andreas J. Koenig
+
+=item * Florian Ragwitz
+
+=item * Corion
+
+=item * Mark Stosberg
+
+=item * Matt Kraai
+
+=back
+
+=head1 AUTHORS
+
+Curtis "Ovid" Poe <ovid@cpan.org>
+
+Andy Armstong <andy@hexten.net>
+
+Eric Wilhelm @ <ewilhelm at cpan dot org>
+
+Michael Peters <mpeters at plusthree dot com>
+
+Leif Eriksen <leif dot eriksen at bigpond dot com>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-tapx-parser@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
+We will be notified, and then you'll automatically be notified of
+progress on your bug as we make changes.
+
+Obviously, bugs which include patches are best. If you prefer, you can
+patch against bleed by via anonymous checkout of the latest version:
+
+ svn checkout http://svn.hexten.net/tapx
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2006-2007 Curtis "Ovid" Poe, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Aggregator;
+
+use strict;
+use Benchmark;
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Aggregator - Aggregate TAP::Parser results
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Aggregator;
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+ $aggregate->add( 't/00-load.t', $load_parser );
+ $aggregate->add( 't/10-lex.t', $lex_parser );
+
+ my $summary = <<'END_SUMMARY';
+ Passed: %s
+ Failed: %s
+ Unexpectedly succeeded: %s
+ END_SUMMARY
+ printf $summary,
+ scalar $aggregate->passed,
+ scalar $aggregate->failed,
+ scalar $aggregate->todo_passed;
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Aggregator> collects parser objects and allows
+reporting/querying their aggregate results.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $aggregate = TAP::Parser::Aggregator->new;
+
+Returns a new C<TAP::Parser::Aggregator> object.
+
+=cut
+
+my %SUMMARY_METHOD_FOR;
+
+BEGIN { # install summary methods
+ %SUMMARY_METHOD_FOR = map { $_ => $_ } qw(
+ failed
+ parse_errors
+ passed
+ skipped
+ todo
+ todo_passed
+ total
+ wait
+ exit
+ );
+ $SUMMARY_METHOD_FOR{total} = 'tests_run';
+
+ foreach my $method ( keys %SUMMARY_METHOD_FOR ) {
+ next if 'total' eq $method;
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return wantarray
+ ? @{ $self->{"descriptions_for_$method"} }
+ : $self->{$method};
+ };
+ }
+} # end install summary methods
+
+sub new {
+ my ($class) = @_;
+ my $self = bless {}, $class;
+ $self->_initialize;
+ return $self;
+}
+
+sub _initialize {
+ my ($self) = @_;
+ $self->{parser_for} = {};
+ $self->{parse_order} = [];
+ foreach my $summary ( keys %SUMMARY_METHOD_FOR ) {
+ $self->{$summary} = 0;
+ next if 'total' eq $summary;
+ $self->{"descriptions_for_$summary"} = [];
+ }
+ return $self;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $aggregate->add( $description => $parser );
+
+The C<$description> is usually a test file name (but only by
+convention.) It is used as a unique identifier (see e.g.
+L<"parsers">.) Reusing a description is a fatal error.
+
+The C<$parser> is a L<TAP::Parser|TAP::Parser> object.
+
+=cut
+
+sub add {
+ my ( $self, $description, $parser ) = @_;
+ if ( exists $self->{parser_for}{$description} ) {
+ $self->_croak( "You already have a parser for ($description)."
+ . " Perhaps you have run the same test twice." );
+ }
+ push @{ $self->{parse_order} } => $description;
+ $self->{parser_for}{$description} = $parser;
+
+ while ( my ( $summary, $method ) = each %SUMMARY_METHOD_FOR ) {
+ if ( my $count = $parser->$method() ) {
+ $self->{$summary} += $count;
+ push @{ $self->{"descriptions_for_$summary"} } => $description;
+ }
+ }
+
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<parsers>
+
+ my $count = $aggregate->parsers;
+ my @parsers = $aggregate->parsers;
+ my @parsers = $aggregate->parsers(@descriptions);
+
+In scalar context without arguments, this method returns the number of parsers
+aggregated. In list context without arguments, returns the parsers in the
+order they were added.
+
+If C<@descriptions> is given, these correspond to the keys used in each
+call to the add() method. Returns an array of the requested parsers (in
+the requested order) in list context or an array reference in scalar
+context.
+
+Requesting an unknown identifier is a fatal error.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->_get_parsers(@_) if @_;
+ my $descriptions = $self->{parse_order};
+ my @parsers = @{ $self->{parser_for} }{@$descriptions};
+
+ # Note: Because of the way context works, we must assign the parsers to
+ # the @parsers array or else this method does not work as documented.
+ return @parsers;
+}
+
+sub _get_parsers {
+ my ( $self, @descriptions ) = @_;
+ my @parsers;
+ foreach my $description (@descriptions) {
+ $self->_croak("A parser for ($description) could not be found")
+ unless exists $self->{parser_for}{$description};
+ push @parsers => $self->{parser_for}{$description};
+ }
+ return wantarray ? @parsers : \@parsers;
+}
+
+=head3 C<descriptions>
+
+Get an array of descriptions in the order in which they were added to the aggregator.
+
+=cut
+
+sub descriptions { @{ shift->{parse_order} || [] } }
+
+=head3 C<start>
+
+Call C<start> immediately before adding any results to the aggregator.
+Among other times it records the start time for the test run.
+
+=cut
+
+sub start {
+ my $self = shift;
+ $self->{start_time} = Benchmark->new;
+}
+
+=head3 C<stop>
+
+Call C<stop> immediately after adding all test results to the aggregator.
+
+=cut
+
+sub stop {
+ my $self = shift;
+ $self->{end_time} = Benchmark->new;
+}
+
+=head3 C<elapsed>
+
+Elapsed returns a L<Benchmark> object that represents the running time
+of the aggregated tests. In order for C<elapsed> to be valid you must
+call C<start> before running the tests and C<stop> immediately
+afterwards.
+
+=cut
+
+sub elapsed {
+ my $self = shift;
+
+ require Carp;
+ Carp::croak
+ q{Can't call elapsed without first calling start and then stop}
+ unless defined $self->{start_time} && defined $self->{end_time};
+ return timediff( $self->{end_time}, $self->{start_time} );
+}
+
+=head3 C<elapsed_timestr>
+
+Returns a formatted string representing the runtime returned by
+C<elapsed()>. This lets the caller not worry about Benchmark.
+
+=cut
+
+sub elapsed_timestr {
+ my $self = shift;
+
+ my $elapsed = $self->elapsed;
+
+ return timestr($elapsed);
+}
+
+=head3 C<all_passed>
+
+Return true if all the tests passed and no parse errors were detected.
+
+=cut
+
+sub all_passed {
+ my $self = shift;
+ return $self->total
+ && $self->total == $self->passed
+ && !$self->has_errors;
+}
+
+=head3 C<get_status>
+
+Get a single word describing the status of the aggregated tests.
+Depending on the outcome of the tests returns 'PASS', 'FAIL' or
+'NOTESTS'. This token is understood by L<CPAN::Reporter>.
+
+=cut
+
+sub get_status {
+ my $self = shift;
+
+ my $total = $self->total;
+ my $passed = $self->passed;
+
+ return
+ ( $self->has_errors || $total != $passed ) ? 'FAIL'
+ : $total ? 'PASS'
+ : 'NOTESTS';
+}
+
+##############################################################################
+
+=head2 Summary methods
+
+Each of the following methods will return the total number of corresponding
+tests if called in scalar context. If called in list context, returns the
+descriptions of the parsers which contain the corresponding tests (see C<add>
+for an explanation of description.
+
+=over 4
+
+=item * failed
+
+=item * parse_errors
+
+=item * passed
+
+=item * skipped
+
+=item * todo
+
+=item * todo_passed
+
+=item * wait
+
+=item * exit
+
+=back
+
+For example, to find out how many tests unexpectedly succeeded (TODO tests
+which passed when they shouldn't):
+
+ my $count = $aggregate->todo_passed;
+ my @descriptions = $aggregate->todo_passed;
+
+Note that C<wait> and C<exit> are the totals of the wait and exit
+statuses of each of the tests. These values are totalled only to provide
+a true value if any of them are non-zero.
+
+=cut
+
+##############################################################################
+
+=head3 C<total>
+
+ my $tests_run = $aggregate->total;
+
+Returns the total number of tests run.
+
+=cut
+
+sub total { shift->{total} }
+
+##############################################################################
+
+=head3 C<has_problems>
+
+ if ( $parser->has_problems ) {
+ ...
+ }
+
+Identical to C<has_errors>, but also returns true if any TODO tests
+unexpectedly succeeded. This is more akin to "warnings".
+
+=cut
+
+sub has_problems {
+ my $self = shift;
+ return $self->todo_passed
+ || $self->has_errors;
+}
+
+##############################################################################
+
+=head3 C<has_errors>
+
+ if ( $parser->has_errors ) {
+ ...
+ }
+
+Returns true if I<any> of the parsers failed. This includes:
+
+=over 4
+
+=item * Failed tests
+
+=item * Parse erros
+
+=item * Bad exit or wait status
+
+=back
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ return $self->failed
+ || $self->parse_errors
+ || $self->exit
+ || $self->wait;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # 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<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn
+ '"todo_failed" is deprecated. Please use "todo_passed". See the docs.';
+ goto &todo_passed;
+}
+
+sub _croak {
+ my $proto = shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Grammar;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Result ();
+use TAP::Parser::YAMLish::Reader ();
+
+=head1 NAME
+
+TAP::Parser::Grammar - A grammar for the Test Anything Protocol.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Grammar> tokenizes lines from a TAP stream and constructs
+L<TAP::Parser::Result> subclasses to represent the tokens.
+
+Do not attempt to use this class directly. It won't make sense. It's mainly
+here to ensure that we will be able to have pluggable grammars when TAP is
+expanded at some future date (plus, this stuff was really cluttering the
+parser).
+
+=cut
+
+##############################################################################
+
+=head2 Class Methods
+
+
+=head3 C<new>
+
+ my $grammar = TAP::Grammar->new($stream);
+
+Returns TAP grammar object that will parse the specified stream.
+
+=cut
+
+sub new {
+ my ( $class, $stream ) = @_;
+ my $self = bless { stream => $stream }, $class;
+ $self->set_version(12);
+ return $self;
+}
+
+my %language_for;
+
+{
+
+ # XXX the 'not' and 'ok' might be on separate lines in VMS ...
+ my $ok = qr/(?:not )?ok\b/;
+ my $num = qr/\d+/;
+
+ my %v12 = (
+ version => {
+ syntax => qr/^TAP\s+version\s+(\d+)\s*\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $version = $1;
+ return $self->_make_version_token( $line, $version, );
+ },
+ },
+ plan => {
+ syntax => qr/^1\.\.(\d+)\s*(.*)\z/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $tail ) = ( $1, $2 );
+ my $explanation = undef;
+ my $skip = '';
+
+ if ( $tail =~ /^todo((?:\s+\d+)+)/ ) {
+ my @todo = split /\s+/, _trim($1);
+ return $self->_make_plan_token(
+ $line, $tests_planned, 'TODO',
+ '', \@todo
+ );
+ }
+ elsif ( 0 == $tests_planned ) {
+ $skip = 'SKIP';
+ $explanation = $tail;
+
+ # Trim valid SKIP directive without being strict
+ # about its presence.
+ $explanation =~ s/^#\s*//;
+ $explanation =~ s/^skip\S*\s+//i;
+ }
+ elsif ( $tail !~ /^\s*$/ ) {
+ return $self->_make_unknown_token($line);
+ }
+
+ $explanation = '' unless defined $explanation;
+
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+
+ },
+ },
+
+ # An optimization to handle the most common test lines without
+ # directives.
+ simple_test => {
+ syntax => qr/^($ok) \ ($num) (?:\ ([^#]+))? \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+
+ return $self->_make_test_token(
+ $line, $ok, $num,
+ $desc
+ );
+ },
+ },
+ test => {
+ syntax => qr/^($ok) \s* ($num)? \s* (.*) \z/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $ok, $num, $desc ) = ( $1, $2, $3 );
+ my ( $dir, $explanation ) = ( '', '' );
+ if ($desc =~ m/^ ( [^\\\#]* (?: \\. [^\\\#]* )* )
+ \# \s* (SKIP|TODO) \b \s* (.*) $/ix
+ )
+ {
+ ( $desc, $dir, $explanation ) = ( $1, $2, $3 );
+ }
+ return $self->_make_test_token(
+ $line, $ok, $num, $desc,
+ uc $dir, $explanation
+ );
+ },
+ },
+ comment => {
+ syntax => qr/^#(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $comment = $1;
+ return $self->_make_comment_token( $line, $comment );
+ },
+ },
+ bailout => {
+ syntax => qr/^Bail out!\s*(.*)/,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my $explanation = $1;
+ return $self->_make_bailout_token(
+ $line,
+ $explanation
+ );
+ },
+ },
+ );
+
+ my %v13 = (
+ %v12,
+ plan => {
+ syntax => qr/^1\.\.(\d+)(?:\s*#\s*SKIP\b(.*))?\z/i,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $tests_planned, $explanation ) = ( $1, $2 );
+ my $skip
+ = ( 0 == $tests_planned || defined $explanation )
+ ? 'SKIP'
+ : '';
+ $explanation = '' unless defined $explanation;
+ return $self->_make_plan_token(
+ $line, $tests_planned, $skip,
+ $explanation, []
+ );
+ },
+ },
+ yaml => {
+ syntax => qr/^ (\s+) (---.*) $/x,
+ handler => sub {
+ my ( $self, $line ) = @_;
+ my ( $pad, $marker ) = ( $1, $2 );
+ return $self->_make_yaml_token( $pad, $marker );
+ },
+ },
+ );
+
+ %language_for = (
+ '12' => {
+ tokens => \%v12,
+ },
+ '13' => {
+ tokens => \%v13,
+ setup => sub {
+ shift->{stream}->handle_unicode;
+ },
+ },
+ );
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<set_version>
+
+ $grammar->set_version(13);
+
+Tell the grammar which TAP syntax version to support. The lowest
+supported version is 12. Although 'TAP version' isn't valid version 12
+syntax it is accepted so that higher version numbers may be parsed.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ if ( my $language = $language_for{$version} ) {
+ $self->{tokens} = $language->{tokens};
+
+ if ( my $setup = $language->{setup} ) {
+ $self->$setup();
+ }
+
+ $self->_order_tokens;
+ }
+ else {
+ require Carp;
+ Carp::croak("Unsupported syntax version: $version");
+ }
+}
+
+# Optimization to put the most frequent tokens first.
+sub _order_tokens {
+ my $self = shift;
+
+ my %copy = %{ $self->{tokens} };
+ my @ordered_tokens = grep {defined}
+ map { delete $copy{$_} } qw( simple_test test comment plan );
+ push @ordered_tokens, values %copy;
+
+ $self->{ordered_tokens} = \@ordered_tokens;
+}
+
+##############################################################################
+
+=head3 C<tokenize>
+
+ my $token = $grammar->tokenize;
+
+This method will return a L<TAP::Parser::Result> object representing the
+current line of TAP.
+
+=cut
+
+sub tokenize {
+ my $self = shift;
+
+ my $line = $self->{stream}->next;
+ return unless defined $line;
+
+ my $token;
+
+ foreach my $token_data ( @{ $self->{ordered_tokens} } ) {
+ if ( $line =~ $token_data->{syntax} ) {
+ my $handler = $token_data->{handler};
+ $token = $self->$handler($line);
+ last;
+ }
+ }
+
+ $token = $self->_make_unknown_token($line) unless $token;
+
+ return TAP::Parser::Result->new($token);
+}
+
+##############################################################################
+
+=head3 C<token_types>
+
+ my @types = $grammar->token_types;
+
+Returns the different types of tokens which this grammar can parse.
+
+=cut
+
+sub token_types {
+ my $self = shift;
+ return keys %{ $self->{tokens} };
+}
+
+##############################################################################
+
+=head3 C<syntax_for>
+
+ my $syntax = $grammar->syntax_for($token_type);
+
+Returns a pre-compiled regular expression which will match a chunk of TAP
+corresponding to the token type. For example (not that you should really pay
+attention to this, C<< $grammar->syntax_for('comment') >> will return
+C<< qr/^#(.*)/ >>.
+
+=cut
+
+sub syntax_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{syntax};
+}
+
+##############################################################################
+
+=head3 C<handler_for>
+
+ my $handler = $grammar->handler_for($token_type);
+
+Returns a code reference which, when passed an appropriate line of TAP,
+returns the lexed token corresponding to that line. As a result, the basic
+TAP parsing loop looks similar to the following:
+
+ my @tokens;
+ my $grammar = TAP::Grammar->new;
+ LINE: while ( defined( my $line = $parser->_next_chunk_of_tap ) ) {
+ foreach my $type ( $grammar->token_types ) {
+ my $syntax = $grammar->syntax_for($type);
+ if ( $line =~ $syntax ) {
+ my $handler = $grammar->handler_for($type);
+ push @tokens => $grammar->$handler($line);
+ next LINE;
+ }
+ }
+ push @tokens => $grammar->_make_unknown_token($line);
+ }
+
+=cut
+
+sub handler_for {
+ my ( $self, $type ) = @_;
+ return $self->{tokens}->{$type}->{handler};
+}
+
+sub _make_version_token {
+ my ( $self, $line, $version ) = @_;
+ return {
+ type => 'version',
+ raw => $line,
+ version => $version,
+ };
+}
+
+sub _make_plan_token {
+ my ( $self, $line, $tests_planned, $directive, $explanation, $todo ) = @_;
+
+ if ( $directive eq 'SKIP' && 0 != $tests_planned ) {
+ warn
+ "Specified SKIP directive in plan but more than 0 tests ($line)\n";
+ }
+ return {
+ type => 'plan',
+ raw => $line,
+ tests_planned => $tests_planned,
+ directive => $directive,
+ explanation => _trim($explanation),
+ todo_list => $todo,
+ };
+}
+
+sub _make_test_token {
+ my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_;
+ my %test = (
+ ok => $ok,
+ test_num => $num,
+ description => _trim($desc),
+ directive => uc($dir),
+ explanation => _trim($explanation),
+ raw => $line,
+ type => 'test',
+ );
+ return \%test;
+}
+
+sub _make_unknown_token {
+ my ( $self, $line ) = @_;
+ return {
+ raw => $line,
+ type => 'unknown',
+ };
+}
+
+sub _make_comment_token {
+ my ( $self, $line, $comment ) = @_;
+ return {
+ type => 'comment',
+ raw => $line,
+ comment => _trim($comment)
+ };
+}
+
+sub _make_bailout_token {
+ my ( $self, $line, $explanation ) = @_;
+ return {
+ type => 'bailout',
+ raw => $line,
+ bailout => _trim($explanation)
+ };
+}
+
+sub _make_yaml_token {
+ my ( $self, $pad, $marker ) = @_;
+
+ my $yaml = TAP::Parser::YAMLish::Reader->new;
+
+ my $stream = $self->{stream};
+
+ # Construct a reader that reads from our input stripping leading
+ # spaces from each line.
+ my $leader = length($pad);
+ my $strip = qr{ ^ (\s{$leader}) (.*) $ }x;
+ my @extra = ($marker);
+ my $reader = sub {
+ return shift @extra if @extra;
+ my $line = $stream->next;
+ return $2 if $line =~ $strip;
+ return;
+ };
+
+ my $data = $yaml->read($reader);
+
+ # Reconstitute input. This is convoluted. Maybe we should just
+ # record it on the way in...
+ chomp( my $raw = $yaml->get_raw );
+ $raw =~ s/^/$pad/mg;
+
+ return {
+ type => 'yaml',
+ raw => $raw,
+ data => $data
+ };
+}
+
+sub _trim {
+ my $data = shift;
+
+ return '' unless defined $data;
+
+ $data =~ s/^\s+//;
+ $data =~ s/\s+$//;
+ return $data;
+}
+
+=head1 TAP GRAMMAR
+
+B<NOTE:> This grammar is slightly out of date. There's still some discussion
+about it and a new one will be provided when we have things better defined.
+
+The L<TAP::Parser> does not use a formal grammar because TAP is essentially a
+stream-based protocol. In fact, it's quite legal to have an infinite stream.
+For the same reason that we don't apply regexes to streams, we're not using a
+formal grammar here. Instead, we parse the TAP in lines.
+
+For purposes for forward compatability, any result which does not match the
+following grammar is currently referred to as
+L<TAP::Parser::Result::Unknown>. It is I<not> a parse error.
+
+A formal grammar would look similar to the following:
+
+ (*
+ For the time being, I'm cheating on the EBNF by allowing
+ certain terms to be defined by POSIX character classes by
+ using the following syntax:
+
+ digit ::= [:digit:]
+
+ As far as I am aware, that's not valid EBNF. Sue me. I
+ didn't know how to write "char" otherwise (Unicode issues).
+ Suggestions welcome.
+ *)
+
+ tap ::= version? { comment | unknown } leading_plan lines
+ |
+ lines trailing_plan {comment}
+
+ version ::= 'TAP version ' positiveInteger {positiveInteger} "\n"
+
+ leading_plan ::= plan skip_directive? "\n"
+
+ trailing_plan ::= plan "\n"
+
+ plan ::= '1..' nonNegativeInteger
+
+ lines ::= line {line}
+
+ line ::= (comment | test | unknown | bailout ) "\n"
+
+ test ::= status positiveInteger? description? directive?
+
+ status ::= 'not '? 'ok '
+
+ description ::= (character - (digit | '#')) {character - '#'}
+
+ directive ::= todo_directive | skip_directive
+
+ todo_directive ::= hash_mark 'TODO' ' ' {character}
+
+ skip_directive ::= hash_mark 'SKIP' ' ' {character}
+
+ comment ::= hash_mark {character}
+
+ hash_mark ::= '#' {' '}
+
+ bailout ::= 'Bail out!' {character}
+
+ unknown ::= { (character - "\n") }
+
+ (* POSIX character classes and other terminals *)
+
+ digit ::= [:digit:]
+ character ::= ([:print:] - "\n")
+ positiveInteger ::= ( digit - '0' ) {digit}
+ nonNegativeInteger ::= digit {digit}
+
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Iterator;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Iterator::Array ();
+use TAP::Parser::Iterator::Stream ();
+use TAP::Parser::Iterator::Process ();
+
+=head1 NAME
+
+TAP::Parser::Iterator - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator;
+ my $it = TAP::Parser::Iterator->new(\*TEST);
+ my $it = TAP::Parser::Iterator->new(\@array);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for arrays and filehandles.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $iter = TAP::Parser::Iterator->new( $array_reference );
+ my $iter = TAP::Parser::Iterator->new( $filehandle );
+
+Create an iterator.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+ while ( my $item = $iter->next ) { ... }
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+ while ( my $item = $iter->next_raw ) { ... }
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=cut
+
+sub new {
+ my ( $proto, $thing ) = @_;
+
+ my $ref = ref $thing;
+ if ( $ref eq 'GLOB' || $ref eq 'IO::Handle' ) {
+ return TAP::Parser::Iterator::Stream->new($thing);
+ }
+ elsif ( $ref eq 'ARRAY' ) {
+ return TAP::Parser::Iterator::Array->new($thing);
+ }
+ elsif ( $ref eq 'HASH' ) {
+ return TAP::Parser::Iterator::Process->new($thing);
+ }
+ else {
+ die "Can't iterate with a $ref";
+ }
+}
+
+sub next {
+ my $self = shift;
+ my $line = $self->next_raw;
+
+ # vms nit: When encountering 'not ok', vms often has the 'not' on a line
+ # by itself:
+ # not
+ # ok 1 - 'I hate VMS'
+ if ( defined($line) and $line =~ /^\s*not\s*$/ ) {
+ $line .= ( $self->next_raw || '' );
+ }
+
+ return $line;
+}
+
+=head3 C<handle_unicode>
+
+If necessary switch the input stream to handle unicode. This only has
+any effect for I/O handle based streams.
+
+=cut
+
+sub handle_unicode { }
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {return}
+
+1;
--- /dev/null
+package TAP::Parser::Iterator::Array;
+
+use strict;
+use TAP::Parser::Iterator ();
+use vars qw($VERSION @ISA);
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Array - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator::Array;
+ my $it = TAP::Parser::Iterator->new(\@array);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for arrays.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. For an array iterator this will always
+be zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. For an array iterator this will always
+be zero.
+
+=cut
+
+sub new {
+ my ( $class, $thing ) = @_;
+ chomp @$thing;
+ bless {
+ idx => 0,
+ array => $thing,
+ exit => undef,
+ }, $class;
+}
+
+sub wait { shift->exit }
+
+sub exit {
+ my $self = shift;
+ return 0 if $self->{idx} >= @{ $self->{array} };
+ return;
+}
+
+sub next_raw {
+ my $self = shift;
+ return $self->{array}->[ $self->{idx}++ ];
+}
+
+1;
--- /dev/null
+package TAP::Parser::Iterator::Process;
+
+use strict;
+
+use TAP::Parser::Iterator ();
+
+use vars qw($VERSION @ISA);
+
+@ISA = 'TAP::Parser::Iterator';
+
+use Config;
+use IO::Handle;
+
+my $IS_WIN32 = ( $^O =~ /^(MS)?Win32$/ );
+
+=head1 NAME
+
+TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator;
+ my $it = TAP::Parser::Iterator::Process->new(@args);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for processes.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator's process.
+
+=head3 C<exit>
+
+Get the exit status for this iterator's process.
+
+=cut
+
+eval { require POSIX; &POSIX::WEXITSTATUS(0) };
+if ($@) {
+ *_wait2exit = sub { $_[1] >> 8 };
+}
+else {
+ *_wait2exit = sub { POSIX::WEXITSTATUS( $_[1] ) }
+}
+
+sub _use_open3 {
+ my $self = shift;
+ return unless $Config{d_fork} || $IS_WIN32;
+ for my $module (qw( IPC::Open3 IO::Select )) {
+ eval "use $module";
+ return if $@;
+ }
+ return 1;
+}
+
+{
+ my $got_unicode;
+
+ sub _get_unicode {
+ return $got_unicode if defined $got_unicode;
+ eval 'use Encode qw(decode_utf8);';
+ $got_unicode = $@ ? 0 : 1;
+
+ }
+}
+
+sub new {
+ my $class = shift;
+ my $args = shift;
+
+ my @command = @{ delete $args->{command} || [] }
+ or die "Must supply a command to execute";
+
+ # Private. Used to frig with chunk size during testing.
+ my $chunk_size = delete $args->{_chunk_size} || 65536;
+
+ my $merge = delete $args->{merge};
+ my ( $pid, $err, $sel );
+
+ if ( my $setup = delete $args->{setup} ) {
+ $setup->(@command);
+ }
+
+ my $out = IO::Handle->new;
+
+ if ( $class->_use_open3 ) {
+
+ # HOTPATCH {{{
+ my $xclose = \&IPC::Open3::xclose;
+ local $^W; # no warnings
+ local *IPC::Open3::xclose = sub {
+ my $fh = shift;
+ no strict 'refs';
+ return if ( fileno($fh) == fileno(STDIN) );
+ $xclose->($fh);
+ };
+
+ # }}}
+
+ if ($IS_WIN32) {
+ $err = $merge ? '' : '>&STDERR';
+ eval {
+ $pid = open3(
+ '<&STDIN', $out, $merge ? '' : $err,
+ @command
+ );
+ };
+ die "Could not execute (@command): $@" if $@;
+ if ( $] >= 5.006 ) {
+
+ # Kludge to avoid warning under 5.5
+ eval 'binmode($out, ":crlf")';
+ }
+ }
+ else {
+ $err = $merge ? '' : IO::Handle->new;
+ eval { $pid = open3( '<&STDIN', $out, $err, @command ); };
+ die "Could not execute (@command): $@" if $@;
+ $sel = $merge ? undef : IO::Select->new( $out, $err );
+ }
+ }
+ else {
+ $err = '';
+ my $command
+ = join( ' ', map { $_ =~ /\s/ ? qq{"$_"} : $_ } @command );
+ open( $out, "$command|" )
+ or die "Could not execute ($command): $!";
+ }
+
+ my $self = bless {
+ out => $out,
+ err => $err,
+ sel => $sel,
+ pid => $pid,
+ exit => undef,
+ chunk_size => $chunk_size,
+ }, $class;
+
+ if ( my $teardown = delete $args->{teardown} ) {
+ $self->{teardown} = sub {
+ $teardown->(@command);
+ };
+ }
+
+ return $self;
+}
+
+=head3 C<handle_unicode>
+
+Upgrade the input stream to handle UTF8.
+
+=cut
+
+sub handle_unicode {
+ my $self = shift;
+
+ if ( $self->{sel} ) {
+ if ( _get_unicode() ) {
+
+ # Make sure our iterator has been constructed and...
+ my $next = $self->{_next} ||= $self->_next;
+
+ # ...wrap it to do UTF8 casting
+ $self->{_next} = sub {
+ my $line = $next->();
+ return decode_utf8($line) if defined $line;
+ return;
+ };
+ }
+ }
+ else {
+ if ( $] >= 5.008 ) {
+ eval 'binmode($self->{out}, ":utf8")';
+ }
+ }
+
+}
+
+##############################################################################
+
+sub wait { shift->{wait} }
+sub exit { shift->{exit} }
+
+sub _next {
+ my $self = shift;
+
+ if ( my $out = $self->{out} ) {
+ if ( my $sel = $self->{sel} ) {
+ my $err = $self->{err};
+ my @buf = ();
+ my $partial = ''; # Partial line
+ my $chunk_size = $self->{chunk_size};
+ return sub {
+ return shift @buf if @buf;
+
+ READ:
+ while ( my @ready = $sel->can_read ) {
+ for my $fh (@ready) {
+ my $got = sysread $fh, my ($chunk), $chunk_size;
+
+ if ( $got == 0 ) {
+ $sel->remove($fh);
+ }
+ elsif ( $fh == $err ) {
+ print STDERR $chunk; # echo STDERR
+ }
+ else {
+ $chunk = $partial . $chunk;
+ $partial = '';
+
+ # Make sure we have a complete line
+ unless ( substr( $chunk, -1, 1 ) eq "\n" ) {
+ my $nl = rindex $chunk, "\n";
+ if ( $nl == -1 ) {
+ $partial = $chunk;
+ redo READ;
+ }
+ else {
+ $partial = substr( $chunk, $nl + 1 );
+ $chunk = substr( $chunk, 0, $nl );
+ }
+ }
+
+ push @buf, split /\n/, $chunk;
+ return shift @buf if @buf;
+ }
+ }
+ }
+
+ # Return partial last line
+ if ( length $partial ) {
+ my $last = $partial;
+ $partial = '';
+ return $last;
+ }
+
+ $self->_finish;
+ return;
+ };
+ }
+ else {
+ return sub {
+ if ( defined( my $line = <$out> ) ) {
+ chomp $line;
+ return $line;
+ }
+ $self->_finish;
+ return;
+ };
+ }
+ }
+ else {
+ return sub {
+ $self->_finish;
+ return;
+ };
+ }
+}
+
+sub next_raw {
+ my $self = shift;
+ return ( $self->{_next} ||= $self->_next )->();
+}
+
+sub _finish {
+ my $self = shift;
+
+ my $status = $?;
+
+ # If we have a subprocess we need to wait for it to terminate
+ if ( defined $self->{pid} ) {
+ if ( $self->{pid} == waitpid( $self->{pid}, 0 ) ) {
+ $status = $?;
+ }
+ }
+
+ ( delete $self->{out} )->close if $self->{out};
+
+ # If we have an IO::Select we also have an error handle to close.
+ if ( $self->{sel} ) {
+ ( delete $self->{err} )->close;
+ delete $self->{sel};
+ }
+ else {
+ $status = $?;
+ }
+
+ # Sometimes we get -1 on Windows. Presumably that means status not
+ # available.
+ $status = 0 if $IS_WIN32 && $status == -1;
+
+ $self->{wait} = $status;
+ $self->{exit} = $self->_wait2exit($status);
+
+ if ( my $teardown = $self->{teardown} ) {
+ $teardown->();
+ }
+
+ return $self;
+}
+
+=head3 C<get_select_handles>
+
+Return a list of filehandles that may be used upstream in a select()
+call to signal that this Iterator is ready. Iterators that are not
+handle based should return an empty list.
+
+=cut
+
+sub get_select_handles {
+ my $self = shift;
+ return grep $_, ( $self->{out}, $self->{err} );
+}
+
+1;
--- /dev/null
+package TAP::Parser::Iterator::Stream;
+
+use strict;
+use TAP::Parser::Iterator ();
+use vars qw($VERSION @ISA);
+@ISA = 'TAP::Parser::Iterator';
+
+=head1 NAME
+
+TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Iterator;
+ my $it = TAP::Parser::Iterator::Stream->new(\*TEST);
+
+ my $line = $it->next;
+
+Originally ripped off from L<Test::Harness>.
+
+=head1 DESCRIPTION
+
+B<FOR INTERNAL USE ONLY!>
+
+This is a simple iterator wrapper for filehandles.
+
+=head2 Class Methods
+
+=head3 C<new>
+
+Create an iterator.
+
+=head2 Instance Methods
+
+=head3 C<next>
+
+Iterate through it, of course.
+
+=head3 C<next_raw>
+
+Iterate raw input without applying any fixes for quirky input syntax.
+
+=head3 C<wait>
+
+Get the wait status for this iterator. Always returns zero.
+
+=head3 C<exit>
+
+Get the exit status for this iterator. Always returns zero.
+
+=cut
+
+sub new {
+ my ( $class, $thing ) = @_;
+ bless {
+ fh => $thing,
+ }, $class;
+}
+
+##############################################################################
+
+sub wait { shift->exit }
+sub exit { shift->{fh} ? () : 0 }
+
+sub next_raw {
+ my $self = shift;
+ my $fh = $self->{fh};
+
+ if ( defined( my $line = <$fh> ) ) {
+ chomp $line;
+ return $line;
+ }
+ else {
+ $self->_finish;
+ return;
+ }
+}
+
+sub _finish {
+ my $self = shift;
+ close delete $self->{fh};
+}
+
+1;
--- /dev/null
+package TAP::Parser::Multiplexer;
+
+use strict;
+use IO::Select;
+use vars qw($VERSION);
+
+use constant IS_WIN32 => $^O =~ /^(MS)?Win32$/;
+use constant IS_VMS => $^O eq 'VMS';
+use constant SELECT_OK => !( IS_VMS || IS_WIN32 );
+
+=head1 NAME
+
+TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Multiplexer;
+
+ my $mux = TAP::Parser::Multiplexer->new;
+ $mux->add( $parser1, $stash1 );
+ $mux->add( $parser2, $stash2 );
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+ # do stuff
+ }
+
+=head1 DESCRIPTION
+
+C<TAP::Parser::Multiplexer> gathers input from multiple TAP::Parsers.
+Internally it calls select on the input file handles for those parsers
+to wait for one or more of them to have input available.
+
+See L<TAP::Harness> for an example of its use.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $mux = TAP::Parser::Multiplexer->new;
+
+Returns a new C<TAP::Parser::Multiplexer> object.
+
+=cut
+
+sub new {
+ my ($class) = @_;
+ return bless {
+ select => IO::Select->new,
+ avid => [], # Parsers that can't select
+ count => 0,
+ }, $class;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<add>
+
+ $mux->add( $parser, $stash );
+
+Add a TAP::Parser to the multiplexer. C<$stash> is an optional opaque
+reference that will be returned from C<next> along with the parser and
+the next result.
+
+=cut
+
+sub add {
+ my ( $self, $parser, $stash ) = @_;
+
+ if ( SELECT_OK && ( my @handles = $parser->get_select_handles ) ) {
+ my $sel = $self->{select};
+
+ # We have to turn handles into file numbers here because by
+ # the time we want to remove them from our IO::Select they
+ # will already have been closed by the iterator.
+ my @filenos = map { fileno $_ } @handles;
+ for my $h (@handles) {
+ $sel->add( [ $h, $parser, $stash, @filenos ] );
+ }
+
+ $self->{count}++;
+ }
+ else {
+ push @{ $self->{avid} }, [ $parser, $stash ];
+ }
+}
+
+=head3 C<parsers>
+
+ my $count = $mux->parsers;
+
+Returns the number of parsers. Parsers are removed from the multiplexer
+when their input is exhausted.
+
+=cut
+
+sub parsers {
+ my $self = shift;
+ return $self->{count} + scalar @{ $self->{avid} };
+}
+
+sub _iter {
+ my $self = shift;
+
+ my $sel = $self->{select};
+ my $avid = $self->{avid};
+ my @ready = ();
+
+ return sub {
+
+ # Drain all the non-selectable parsers first
+ if (@$avid) {
+ my ( $parser, $stash ) = @{ $avid->[0] };
+ my $result = $parser->next;
+ shift @$avid unless defined $result;
+ return ( $parser, $stash, $result );
+ }
+
+ unless (@ready) {
+ return unless $sel->count;
+
+ # TODO: Win32 doesn't do select properly on handles...
+ @ready = $sel->can_read;
+ }
+
+ my ( $h, $parser, $stash, @handles ) = @{ shift @ready };
+ my $result = $parser->next;
+
+ unless ( defined $result ) {
+ $sel->remove(@handles);
+ $self->{count}--;
+
+ # Force another can_read - we may now have removed a handle
+ # thought to have been ready.
+ @ready = ();
+ }
+
+ return ( $parser, $stash, $result );
+ };
+}
+
+=head3 C<next>
+
+Return a result from the next available parser. Returns a list
+containing the parser from which the result came, the stash that
+corresponds with that parser and the result.
+
+ my ( $parser, $stash, $result ) = $mux->next;
+
+If C<$result> is undefined the corresponding parser has reached the end
+of its input (and will automatically be removed from the multiplexer).
+
+When all parsers are exhausted an empty list will be returned.
+
+ if ( my ( $parser, $stash, $result ) = $mux->next ) {
+ if ( ! defined $result ) {
+ # End of this parser
+ }
+ else {
+ # Process result
+ }
+ }
+ else {
+ # All parsers finished
+ }
+
+=cut
+
+sub next {
+ my $self = shift;
+ return ( $self->{_iter} ||= $self->_iter )->();
+}
+
+=head1 See Also
+
+L<TAP::Parser>
+
+L<TAP::Harness>
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Result;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Result::Bailout ();
+use TAP::Parser::Result::Comment ();
+use TAP::Parser::Result::Plan ();
+use TAP::Parser::Result::Test ();
+use TAP::Parser::Result::Unknown ();
+use TAP::Parser::Result::Version ();
+use TAP::Parser::Result::YAML ();
+
+BEGIN {
+ no strict 'refs';
+ foreach my $token (qw( plan comment test bailout version unknown yaml )) {
+ my $method = "is_$token";
+ *$method = sub { return $token eq shift->type };
+ }
+}
+
+##############################################################################
+
+=head1 NAME
+
+TAP::Parser::Result - TAP::Parser output
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head2 DESCRIPTION
+
+This is merely a factory class which returns an object representing the
+current bit of test data from TAP (usually a line). It's for internal use
+only and should not be relied upon.
+
+=cut
+
+# note that this is bad. Makes it very difficult to subclass, but then, it
+# would be a lot of work to subclass this system.
+my %class_for = (
+ plan => 'TAP::Parser::Result::Plan',
+ test => 'TAP::Parser::Result::Test',
+ comment => 'TAP::Parser::Result::Comment',
+ bailout => 'TAP::Parser::Result::Bailout',
+ version => 'TAP::Parser::Result::Version',
+ unknown => 'TAP::Parser::Result::Unknown',
+ yaml => 'TAP::Parser::Result::YAML',
+);
+
+##############################################################################
+
+=head2 METHODS
+
+=head3 C<new>
+
+ my $result = TAP::Parser::Result->new($token);
+
+Returns an instance the appropriate class for the test token passed in.
+
+=cut
+
+sub new {
+ my ( $class, $token ) = @_;
+ my $type = $token->{type};
+ return bless $token => $class_for{$type}
+ if exists $class_for{$type};
+ require Carp;
+
+ # this should never happen!
+ Carp::croak("Could not determine class for\n$token->{type}");
+}
+
+=head2 Boolean methods
+
+The following methods all return a boolean value and are to be overridden in
+the appropriate subclass.
+
+=over 4
+
+=item * C<is_plan>
+
+Indicates whether or not this is the test plan line.
+
+ 1..3
+
+=item * C<is_test>
+
+Indicates whether or not this is a test line.
+
+ is $foo, $bar, $description;
+
+=item * C<is_comment>
+
+Indicates whether or not this is a comment.
+
+ # this is a comment
+
+=item * C<is_bailout>
+
+Indicates whether or not this is bailout line.
+
+ Bail out! We're out of dilithium crystals.
+
+=item * C<is_version>
+
+Indicates whether or not this is a TAP version line.
+
+ TAP version 4
+
+=item * C<is_unknown>
+
+Indicates whether or not the current line could be parsed.
+
+ ... this line is junk ...
+
+=item * C<is_yaml>
+
+Indicates whether or not this is a YAML chunk.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head3 C<raw>
+
+ print $result->raw;
+
+Returns the original line of text which was parsed.
+
+=cut
+
+sub raw { shift->{raw} }
+
+##############################################################################
+
+=head3 C<type>
+
+ my $type = $result->type;
+
+Returns the "type" of a token, such as C<comment> or C<test>.
+
+=cut
+
+sub type { shift->{type} }
+
+##############################################################################
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+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<raw> method.
+
+=cut
+
+sub as_string { shift->{raw} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Reports whether or not a given result has passed. Anything which is B<not> a
+test result returns true. This is merely provided as a convenient shortcut.
+
+=cut
+
+sub is_ok {1}
+
+##############################################################################
+
+=head3 C<passed>
+
+Deprecated. Please use C<is_ok> instead.
+
+=cut
+
+sub passed {
+ warn 'passed() is deprecated. Please use "is_ok()"';
+ shift->is_ok;
+}
+
+##############################################################################
+
+=head3 C<has_directive>
+
+ if ( $result->has_directive ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO or SKIP directive.
+
+=cut
+
+sub has_directive {
+ my $self = shift;
+ return ( $self->has_todo || $self->has_skip );
+}
+
+##############################################################################
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) {
+ ...
+ }
+
+Indicates whether or not the given result has a TODO directive.
+
+=cut
+
+sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) {
+ ...
+ }
+
+Indicates whether or not the given result has a SKIP directive.
+
+=cut
+
+sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
+
+=head3 C<set_directive>
+
+Set the directive associated with this token. Used internally to fake
+TODO tests.
+
+=cut
+
+sub set_directive {
+ my ( $self, $dir ) = @_;
+ $self->{directive} = $dir;
+}
+
+1;
--- /dev/null
+package TAP::Parser::Result::Bailout;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Bailout - Bailout result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a bail out line is encountered.
+
+ 1..5
+ ok 1 - woo hooo!
+ Bail out! Well, so much for "woo hooo!"
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<explanation>
+
+ 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.
+
+=cut
+
+sub explanation { shift->{bailout} }
+sub as_string { shift->{bailout} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Comment;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Comment - Comment result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a comment line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+ # this is a comment
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+Note that this method merely returns the comment preceded by a '# '.
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<comment>
+
+ if ( $result->is_comment ) {
+ my $comment = $result->comment;
+ print "I have something to say: $comment";
+ }
+
+=cut
+
+sub comment { shift->{comment} }
+sub as_string { shift->{raw} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Plan;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Plan - Plan result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a plan line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<plan>
+
+ if ( $result->is_plan ) {
+ print $result->plan;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub plan { '1..' . shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<tests_planned>
+
+ 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'.
+
+=cut
+
+sub tests_planned { shift->{tests_planned} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $plan->directive;
+
+If a SKIP directive is included with the plan, this method will return it.
+
+ 1..0 # SKIP: why bother?
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<explanation>
+
+ my $explanation = $plan->explanation;
+
+If a SKIP directive was included with the plan, this method will return the
+explanation, if any.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+=head3 C<todo_list>
+
+ my $todo = $result->todo_list;
+ for ( @$todo ) {
+ ...
+ }
+
+=cut
+
+sub todo_list { shift->{todo_list} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::Test;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system. Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+ my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+ my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+ my ( $self, $number ) = @_;
+ $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+ my $description = $result->description;
+
+Returns the description of the test, if any. This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+ my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+ my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> 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<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+ if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed. Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false. See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+ my $self = shift;
+
+ return if $self->is_unplanned;
+
+ # TODO directives reverse the sense of a test.
+ return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+ if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+ my $self = shift;
+ return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated. Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+ warn 'actual_passed() is deprecated. Please use "is_actual_ok()"';
+ goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+ if ( $test->todo_passed ) {
+ # test unexpectedly succeeded
+ }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+ my $self = shift;
+ return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+ # 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<todo_passed>.
+
+=cut
+
+sub todo_failed {
+ warn 'todo_failed() is deprecated. Please use "todo_passed()"';
+ goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+ if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+ if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+ print $result->as_string;
+
+This method prints the test as a string. It will probably be similar, but
+not necessarily identical, to the original test line. Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line. If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+ my $self = shift;
+ my $string = $self->ok . " " . $self->number;
+ if ( my $description = $self->description ) {
+ $string .= " $description";
+ }
+ if ( my $directive = $self->directive ) {
+ my $explanation = $self->explanation;
+ $string .= " # $directive $explanation";
+ }
+ return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+ if ( $test->is_unplanned ) { ... }
+ $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true. Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+ print <<'END';
+ ok 1
+ ok 2
+ 1..1
+ END
+
+=cut
+
+sub is_unplanned {
+ my $self = shift;
+ return ( $self->{unplanned} || '' ) unless @_;
+ $self->{unplanned} = !!shift;
+ return $self;
+}
+
+1;
--- /dev/null
+package TAP::Parser::Result::Unknown;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+TAP::Parser::Result::Unknown - Unknown result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if the parser does not recognize the token line. For example:
+
+ 1..5
+ VERSION 7
+ ok 1 - woo hooo!
+ ... woo hooo! is cool!
+
+In the above "TAP", the second and fourth lines will generate "Unknown"
+tokens.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+1;
--- /dev/null
+package TAP::Parser::Result::Version;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Version - TAP version result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a version line is encountered.
+
+ TAP version 4
+ ok 1
+ not ok 2
+
+The first version of TAP to include an explicit version number is 4.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<version>
+
+ if ( $result->is_version ) {
+ print $result->version;
+ }
+
+This is merely a synonym for C<as_string>.
+
+=cut
+
+sub version { shift->{version} }
+
+1;
--- /dev/null
+package TAP::Parser::Result::YAML;
+
+use strict;
+
+use vars qw($VERSION @ISA);
+use TAP::Parser::Result;
+@ISA = 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::YAML - YAML result token.
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>. A token of this class will be
+returned if a YAML block is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+C<1..1> is the plan. Gotta have a plan.
+
+=head1 OVERRIDDEN METHODS
+
+Mainly listed here to shut up the pitiful screams of the pod coverage tests.
+They keep me awake at night.
+
+=over 4
+
+=item * C<as_string>
+
+=item * C<raw>
+
+=back
+
+=cut
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<data>
+
+ if ( $result->is_yaml ) {
+ print $result->data;
+ }
+
+Return the parsed YAML data for this result
+
+=cut
+
+sub data { shift->{data} }
+
+1;
--- /dev/null
+package TAP::Parser::Source;
+
+use strict;
+use vars qw($VERSION);
+
+use TAP::Parser::Iterator ();
+
+# Causes problem on MacOS and shouldn't be necessary anyway
+#$SIG{CHLD} = sub { wait };
+
+=head1 NAME
+
+TAP::Parser::Source - Stream output from some source
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+Takes a command and hopefully returns a stream from it.
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source;
+ my $source = TAP::Parser::Source->new;
+ my $stream = $source->source(['/usr/bin/ruby', 'mytest.rb'])->get_stream;
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $source = TAP::Parser::Source->new;
+
+Returns a new C<TAP::Parser::Source> object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ _autoflush( \*STDOUT );
+ _autoflush( \*STDERR );
+ bless { switches => [] }, $class;
+}
+
+##############################################################################
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+ my $source = $source->source;
+ $source->source(['./some_prog some_test_file']);
+
+ # or
+ $source->source(['/usr/bin/ruby', 't/ruby_test.rb']);
+
+Getter/setter for the source. The source should generally consist of an array
+reference of strings which, when executed via L<&IPC::Open3::open3|IPC::Open3>, should
+return a filehandle which returns successive rows of TAP.
+
+=cut
+
+sub source {
+ my $self = shift;
+ return $self->{source} unless @_;
+ unless ( 'ARRAY' eq ref $_[0] ) {
+ $self->_croak('Argument to &source must be an array reference');
+ }
+ $self->{source} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a stream of the output generated by executing C<source>.
+
+=cut
+
+sub get_stream {
+ my ($self) = @_;
+ my @command = $self->_get_command
+ or $self->_croak('No command found!');
+
+ return TAP::Parser::Iterator->new(
+ { command => \@command,
+ merge => $self->merge
+ }
+ );
+}
+
+sub _get_command { return @{ shift->source || [] } }
+
+##############################################################################
+
+=head3 C<error>
+
+ unless ( my $stream = $source->get_stream ) {
+ die $source->error;
+ }
+
+If a stream cannot be created, this method will return the error.
+
+=cut
+
+sub error {
+ my $self = shift;
+ return $self->{error} unless @_;
+ $self->{error} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<exit>
+
+ my $exit = $source->exit;
+
+Returns the exit status of the process I<if and only if> an error occurs in
+opening the file.
+
+=cut
+
+sub exit {
+ my $self = shift;
+ return $self->{exit} unless @_;
+ $self->{exit} = shift;
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<merge>
+
+ my $merge = $source->merge;
+
+Sets or returns the flag that dictates whether STDOUT and STDERR are merged.
+
+=cut
+
+sub merge {
+ my $self = shift;
+ return $self->{merge} unless @_;
+ $self->{merge} = shift;
+ return $self;
+}
+
+# Turns on autoflush for the handle passed
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+sub _croak {
+ my $self = shift;
+ require Carp;
+ Carp::croak(@_);
+}
+
+1;
--- /dev/null
+package TAP::Parser::Source::Perl;
+
+use strict;
+use Config;
+use vars qw($VERSION @ISA);
+
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Parser::Source;
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.05
+
+=cut
+
+$VERSION = '3.05';
+
+=head1 DESCRIPTION
+
+Takes a filename and hopefully returns a stream from it. The filename should
+be the name of a Perl program.
+
+Note that this is a subclass of L<TAP::Parser::Source>. See that module for
+more methods.
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::Source::Perl;
+ my $perl = TAP::Parser::Source::Perl->new;
+ my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $perl = TAP::Parser::Source::Perl->new;
+
+Returns a new C<TAP::Parser::Source::Perl> object.
+
+=head2 Instance Methods
+
+=head3 C<source>
+
+Getter/setter the name of the test program and any arguments it requires.
+
+ my ($filename, @args) = @{ $perl->source };
+ $perl->source( [ $filename, @args ] );
+
+=cut
+
+sub source {
+ my $self = shift;
+ $self->_croak("Cannot find ($_[0][0])")
+ if @_ && !-f $_[0][0];
+ return $self->SUPER::source(@_);
+}
+
+=head3 C<switches>
+
+ my $switches = $perl->switches;
+ my @switches = $perl->switches;
+ $perl->switches( \@switches );
+
+Getter/setter for the additional switches to pass to the perl executable. One
+common switch would be to set an include directory:
+
+ $perl->switches( ['-Ilib'] );
+
+=cut
+
+sub switches {
+ my $self = shift;
+ unless (@_) {
+ return wantarray ? @{ $self->{switches} } : $self->{switches};
+ }
+ my $switches = shift;
+ $self->{switches} = [@$switches]; # force a copy
+ return $self;
+}
+
+##############################################################################
+
+=head3 C<get_stream>
+
+ my $stream = $source->get_stream;
+
+Returns a stream of the output generated by executing C<source>.
+
+=cut
+
+sub get_stream {
+ my $self = shift;
+
+ my @extra_libs;
+
+ my @switches = $self->_switches;
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+
+ # Nasty kludge. It might be nicer if we got the libs separately
+ # although at least this way we find any -I switches that were
+ # supplied other then as explicit libs.
+ # We filter out any names containing colons because they will break
+ # PERL5LIB
+ my @libs;
+ for ( grep { $_ !~ $path_pat } @switches ) {
+ push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
+ }
+
+ my $previous = $ENV{PERL5LIB};
+ if ($previous) {
+ push @libs, split( $path_pat, $previous );
+ }
+
+ my $setup = sub {
+ if (@libs) {
+ $ENV{PERL5LIB} = join( $path_sep, @libs );
+ }
+ };
+
+ # Cargo culted from comments seen elsewhere about VMS / environment
+ # variables. I don't know if this is actually necessary.
+ my $teardown = sub {
+ if ($previous) {
+ $ENV{PERL5LIB} = $previous;
+ }
+ else {
+ delete $ENV{PERL5LIB};
+ }
+ };
+
+ # Taint mode ignores environment variables so we must retranslate
+ # PERL5LIB as -I switches and place PERL5OPT on the command line
+ # in order that it be seen.
+ if ( grep { $_ eq "-T" } @switches ) {
+ push @switches,
+ $self->_libs2switches(
+ split $path_pat,
+ $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
+ );
+
+ push @switches, $ENV{PERL5OPT} || ();
+ }
+
+ my @command = $self->_get_command_for_switches(@switches)
+ or $self->_croak("No command found!");
+
+ return TAP::Parser::Iterator->new(
+ { command => \@command,
+ merge => $self->merge,
+ setup => $setup,
+ teardown => $teardown,
+ }
+ );
+}
+
+sub _get_command_for_switches {
+ my $self = shift;
+ my @switches = @_;
+ my ( $file, @args ) = @{ $self->source };
+ my $command = $self->_get_perl;
+
+ $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
+ my @command = ( $command, @switches, $file, @args );
+ return @command;
+}
+
+sub _get_command {
+ my $self = shift;
+ return $self->_get_command_for_switches( $self->_switches );
+}
+
+sub _libs2switches {
+ my $self = shift;
+ return map {"-I$_"} grep {$_} @_;
+}
+
+=head3 C<shebang>
+
+Get the shebang line for a script file.
+
+ my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
+
+May be called as a class method
+
+=cut
+
+{
+
+ # Global shebang cache.
+ my %shebang_for;
+
+ sub _read_shebang {
+ my $file = shift;
+ local *TEST;
+ my $shebang;
+ if ( open( TEST, $file ) ) {
+ $shebang = <TEST>;
+ close(TEST) or print "Can't close $file. $!\n";
+ }
+ else {
+ print "Can't open $file. $!\n";
+ }
+ return $shebang;
+ }
+
+ sub shebang {
+ my ( $class, $file ) = @_;
+ unless ( exists $shebang_for{$file} ) {
+ $shebang_for{$file} = _read_shebang($file);
+ }
+ return $shebang_for{$file};
+ }
+}
+
+=head3 C<get_taint>
+
+Decode any taint switches from a Perl shebang line.
+
+ # $taint will be 't'
+ my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
+
+ # $untaint will be undefined
+ my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
+
+=cut
+
+sub get_taint {
+ my ( $class, $shebang ) = @_;
+ return
+ unless defined $shebang
+ && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
+ return $1;
+}
+
+sub _switches {
+ my $self = shift;
+ my ( $file, @args ) = @{ $self->source };
+ my @switches = (
+ $self->switches,
+ );
+
+ my $shebang = $self->shebang($file);
+ return unless defined $shebang;
+
+ my $taint = $self->get_taint($shebang);
+ push @switches, "-$taint" if defined $taint;
+
+ # Quote the argument if there's any whitespace in it, or if
+ # we're VMS, since VMS requires all parms quoted. Also, don't quote
+ # it if it's already quoted.
+ for (@switches) {
+ $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
+ }
+
+ my %found_switch = map { $_ => 0 } @switches;
+
+ # remove duplicate switches
+ @switches
+ = grep { defined $_ && $_ ne '' && !$found_switch{$_}++ } @switches;
+ return @switches;
+}
+
+sub _get_perl {
+ my $proto = shift;
+ return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+ return Win32::GetShortPathName($^X) if IS_WIN32;
+ return $^X;
+}
+
+1;
--- /dev/null
+package TAP::Parser::YAMLish::Reader;
+
+use strict;
+
+use vars qw{$VERSION};
+
+$VERSION = '3.05';
+
+# TODO:
+# Handle blessed object syntax
+
+# Printable characters for escapes
+my %UNESCAPES = (
+ z => "\x00", a => "\x07", t => "\x09",
+ n => "\x0a", v => "\x0b", f => "\x0c",
+ r => "\x0d", e => "\x1b", '\\' => '\\',
+);
+
+my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
+my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : (?: \s+ (.+?) \s* )? $ }x;
+my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
+my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
+my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
+
+# Create an empty TAP::Parser::YAMLish::Reader object
+sub new {
+ my $class = shift;
+ bless {}, $class;
+}
+
+sub read {
+ my $self = shift;
+ my $obj = shift;
+
+ die "Must have a code reference to read input from"
+ unless ref $obj eq 'CODE';
+
+ $self->{reader} = $obj;
+ $self->{capture} = [];
+
+ #Â Prime the reader
+ $self->_next;
+
+ my $doc = $self->_read;
+
+ # The terminator is mandatory otherwise we'd consume a line from the
+ # iterator that doesn't belong to us. If we want to remove this
+ # restriction we'll have to implement look-ahead in the iterators.
+ # Which might not be a bad idea.
+ my $dots = $self->_peek;
+ die "Missing '...' at end of YAMLish"
+ unless defined $dots
+ and $dots =~ $IS_END_YAML;
+
+ delete $self->{reader};
+ delete $self->{next};
+
+ return $doc;
+}
+
+sub get_raw {
+ my $self = shift;
+
+ if ( defined( my $capture = $self->{capture} ) ) {
+ return join( "\n", @$capture ) . "\n";
+ }
+
+ return '';
+}
+
+sub _peek {
+ my $self = shift;
+ return $self->{next} unless wantarray;
+ my $line = $self->{next};
+ $line =~ /^ (\s*) (.*) $ /x;
+ return ( $2, length $1 );
+}
+
+sub _next {
+ my $self = shift;
+ die "_next called with no reader"
+ unless $self->{reader};
+ my $line = $self->{reader}->();
+ $self->{next} = $line;
+ push @{ $self->{capture} }, $line;
+}
+
+sub _read {
+ my $self = shift;
+
+ my $line = $self->_peek;
+
+ # Do we have a document header?
+ if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) {
+ $self->_next;
+
+ return $self->_read_scalar($1) if defined $1; # Inline?
+
+ my ( $next, $indent ) = $self->_peek;
+
+ if ( $next =~ /^ - /x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $next =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $next, $indent );
+ }
+ elsif ( $next =~ $IS_END_YAML ) {
+ die "Premature end of YAMLish";
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$next'";
+ }
+ }
+ else {
+ die "YAMLish document header not found";
+ }
+}
+
+# Parse a double quoted string
+sub _read_qq {
+ my $self = shift;
+ my $str = shift;
+
+ unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
+ die "Internal: not a quoted string";
+ }
+
+ $str =~ s/\\"/"/gx;
+ $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
+ / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
+ return $str;
+}
+
+# Parse a scalar string to the actual scalar
+sub _read_scalar {
+ my $self = shift;
+ my $string = shift;
+
+ return undef if $string eq '~';
+ return {} if $string eq '{}';
+ return [] if $string eq '[]';
+
+ if ( $string eq '>' || $string eq '|' ) {
+
+ my ( $line, $indent ) = $self->_peek;
+ die "Multi-line scalar content missing" unless defined $line;
+
+ my @multiline = ($line);
+
+ while (1) {
+ $self->_next;
+ my ( $next, $ind ) = $self->_peek;
+ last if $ind < $indent;
+ push @multiline, $next;
+ }
+
+ return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
+ }
+
+ if ( $string =~ /^ ' (.*) ' $/x ) {
+ ( my $rv = $1 ) =~ s/''/'/g;
+ return $rv;
+ }
+
+ if ( $string =~ $IS_QQ_STRING ) {
+ return $self->_read_qq($string);
+ }
+
+ if ( $string =~ /^['"]/ ) {
+
+ # A quote with folding... we don't support that
+ die __PACKAGE__ . " does not support multi-line quoted scalars";
+ }
+
+ # Regular unquoted string
+ return $string;
+}
+
+sub _read_nested {
+ my $self = shift;
+
+ my ( $line, $indent ) = $self->_peek;
+
+ if ( $line =~ /^ -/x ) {
+ return $self->_read_array($indent);
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ return $self->_read_hash( $line, $indent );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+}
+
+# Parse an array
+sub _read_array {
+ my ( $self, $limit ) = @_;
+
+ my $ar = [];
+
+ while (1) {
+ my ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+
+ if ( $indent > $limit ) {
+ die "Array line over-indented";
+ }
+
+ if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
+ $indent += length $1;
+ $line =~ s/-\s+//;
+ push @$ar, $self->_read_hash( $line, $indent );
+ }
+ elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
+ die "Unexpected start of YAMLish" if $line =~ /^---/;
+ $self->_next;
+ push @$ar, $self->_read_scalar($1);
+ }
+ elsif ( $line =~ /^ - \s* $/x ) {
+ $self->_next;
+ push @$ar, $self->_read_nested;
+ }
+ elsif ( $line =~ $IS_HASH_KEY ) {
+ $self->_next;
+ push @$ar, $self->_read_hash( $line, $indent, );
+ }
+ else {
+ die "Unsupported YAMLish syntax: '$line'";
+ }
+ }
+
+ return $ar;
+}
+
+sub _read_hash {
+ my ( $self, $line, $limit ) = @_;
+
+ my $indent;
+ my $hash = {};
+
+ while (1) {
+ die "Badly formed hash line: '$line'"
+ unless $line =~ $HASH_LINE;
+
+ my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
+ $self->_next;
+
+ if ( defined $value ) {
+ $hash->{$key} = $self->_read_scalar($value);
+ }
+ else {
+ $hash->{$key} = $self->_read_nested;
+ }
+
+ ( $line, $indent ) = $self->_peek;
+ last
+ if $indent < $limit
+ || !defined $line
+ || $line =~ $IS_END_YAML;
+ }
+
+ return $hash;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
+
+=head1 VERSION
+
+Version 3.05
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Note that parts of this code were derived from L<YAML::Tiny> with the
+permission of Adam Kennedy.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Reader> object.
+
+ my $reader = TAP::Parser::YAMLish::Reader->new;
+
+=head2 Instance Methods
+
+=head3 C<read>
+
+ my $got = $reader->read($stream);
+
+Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
+represents.
+
+=head3 C<get_raw>
+
+ my $source = $reader->get_source;
+
+Return the raw YAMLish source from the most recent C<read>.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
+the YAML matching regular expressions for this module.
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007 Andy Armstrong.
+
+Portions copyright 2006-2007 Adam Kennedy.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
--- /dev/null
+package TAP::Parser::YAMLish::Writer;
+
+use strict;
+
+use vars qw{$VERSION};
+
+$VERSION = '3.05';
+
+my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
+
+my @UNPRINTABLE = qw(
+ z x01 x02 x03 x04 x05 x06 a
+ x08 t n v f r x0e x0f
+ x10 x11 x12 x13 x14 x15 x16 x17
+ x18 x19 x1a e x1c x1d x1e x1f
+);
+
+# Create an empty TAP::Parser::YAMLish::Writer object
+sub new {
+ my $class = shift;
+ bless {}, $class;
+}
+
+sub write {
+ my $self = shift;
+
+ die "Need something to write"
+ unless @_;
+
+ my $obj = shift;
+ my $out = shift || \*STDOUT;
+
+ die "Need a reference to something I can write to"
+ unless ref $out;
+
+ $self->{writer} = $self->_make_writer($out);
+
+ $self->_write_obj( '---', $obj );
+ $self->_put('...');
+
+ delete $self->{writer};
+}
+
+sub _make_writer {
+ my $self = shift;
+ my $out = shift;
+
+ my $ref = ref $out;
+
+ if ( 'CODE' eq $ref ) {
+ return $out;
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ return sub { push @$out, shift };
+ }
+ elsif ( 'SCALAR' eq $ref ) {
+ return sub { $$out .= shift() . "\n" };
+ }
+ elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
+ return sub { print $out shift(), "\n" };
+ }
+
+ die "Can't write to $out";
+}
+
+sub _put {
+ my $self = shift;
+ $self->{writer}->( join '', @_ );
+}
+
+sub _enc_scalar {
+ my $self = shift;
+ my $val = shift;
+
+ return '~' unless defined $val;
+
+ if ( $val =~ /$ESCAPE_CHAR/ ) {
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/"/\\"/g;
+ $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
+ return qq{"$val"};
+ }
+
+ if ( length($val) == 0 or $val =~ /\s/ ) {
+ $val =~ s/'/''/;
+ return "'$val'";
+ }
+
+ return $val;
+}
+
+sub _write_obj {
+ my $self = shift;
+ my $prefix = shift;
+ my $obj = shift;
+ my $indent = shift || 0;
+
+ if ( my $ref = ref $obj ) {
+ my $pad = ' ' x $indent;
+ if ( 'HASH' eq $ref ) {
+ if ( keys %$obj ) {
+ $self->_put($prefix);
+ for my $key ( sort keys %$obj ) {
+ my $value = $obj->{$key};
+ $self->_write_obj(
+ $pad . $self->_enc_scalar($key) . ':',
+ $value, $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' {}' );
+ }
+ }
+ elsif ( 'ARRAY' eq $ref ) {
+ if (@$obj) {
+ $self->_put($prefix);
+ for my $value (@$obj) {
+ $self->_write_obj(
+ $pad . '-', $value,
+ $indent + 1
+ );
+ }
+ }
+ else {
+ $self->_put( $prefix, ' []' );
+ }
+ }
+ else {
+ die "Don't know how to enocde $ref";
+ }
+ }
+ else {
+ $self->_put( $prefix, ' ', $self->_enc_scalar($obj) );
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+TAP::Parser::YAMLish::Writer - Write YAMLish data
+
+=head1 VERSION
+
+Version 3.05
+
+=head1 SYNOPSIS
+
+ use TAP::Parser::YAMLish::Writer;
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+
+ # Write to an array...
+ $yw->write( $data, \@some_array );
+
+ # ...an open file handle...
+ $yw->write( $data, $some_file_handle );
+
+ # ...a string ...
+ $yw->write( $data, \$some_string );
+
+ # ...or a closure
+ $yw->write( $data, sub {
+ my $line = shift;
+ print "$line\n";
+ } );
+
+=head1 DESCRIPTION
+
+Encodes a scalar, hash reference or array reference as YAMLish.
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $writer = TAP::Parser::YAMLish::Writer->new;
+
+The constructor C<new> creates and returns an empty
+C<TAP::Parser::YAMLish::Writer> object.
+
+=head2 Instance Methods
+
+=head3 C<write>
+
+ $writer->write($obj, $output );
+
+Encode a scalar, hash reference or array reference as YAML.
+
+ my $writer = sub {
+ my $line = shift;
+ print SOMEFILE "$line\n";
+ };
+
+ my $data = {
+ one => 1,
+ two => 2,
+ three => [ 1, 2, 3 ],
+ };
+
+ my $yw = TAP::Parser::YAMLish::Writer->new;
+ $yw->write( $data, $writer );
+
+
+The C< $output > argument may be:
+
+=over
+
+=item * a reference to a scalar to append YAML to
+
+=item * the handle of an open file
+
+=item * a reference to an array into which YAML will be pushed
+
+=item * a code reference
+
+=back
+
+If you supply a code reference the subroutine will be called once for
+each line of output with the line as its only argument. Passed lines
+will have no trailing newline.
+
+=head1 AUTHOR
+
+Andy Armstrong, <andy@hexten.net>
+
+=head1 SEE ALSO
+
+L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
+L<http://use.perl.org/~Alias/journal/29427>
+
+=head1 COPYRIGHT
+
+Copyright 2007 Andy Armstrong.
+
+This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
+The full text of the license can be found in the
+LICENSE file included with this module.
+
+=cut
+
-# -*- Mode: cperl; cperl-indent-level: 4 -*-
-
package Test::Harness;
require 5.00405;
-use Test::Harness::Straps;
-use Test::Harness::Assert;
-use Exporter;
-use Benchmark;
-use Config;
+
use strict;
+use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
+use constant IS_VMS => ( $^O eq 'VMS' );
+
+use TAP::Harness ();
+use TAP::Parser::Aggregator ();
+use TAP::Parser::Source::Perl ();
+use Config;
+use Exporter;
+
+# TODO: Emulate at least some of these
use vars qw(
- $VERSION
- @ISA @EXPORT @EXPORT_OK
- $Verbose $Switches $Debug
- $verbose $switches $debug
- $Columns
- $Timer
- $ML $Last_ML_Print
- $Strap
- $has_time_hires
+ $VERSION
+ @ISA @EXPORT @EXPORT_OK
+ $Verbose $Switches $Debug
+ $verbose $switches $debug
+ $Columns
+ $Directives
+ $Timer
+ $Strap
+ $has_time_hires
);
+# $ML $Last_ML_Print
+
BEGIN {
eval q{use Time::HiRes 'time'};
$has_time_hires = !$@;
=head1 VERSION
-Version 2.64
+Version 3.05
=cut
-$VERSION = '2.64';
+$VERSION = '3.05';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
*switches = *Switches;
*debug = *Debug;
-$ENV{HARNESS_ACTIVE} = 1;
+$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
END {
+
# For VMS.
delete $ENV{HARNESS_ACTIVE};
delete $ENV{HARNESS_VERSION};
}
-my $Files_In_Dir = $ENV{HARNESS_FILELEAK_IN_DIR};
-
-# Stolen from Params::Util
-sub _CLASS {
- (defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*$/s) ? $_[0] : undef;
-}
-
-# Strap Overloading
-if ( $ENV{HARNESS_STRAPS_CLASS} ) {
- die 'Set HARNESS_STRAP_CLASS, singular, not HARNESS_STRAPS_CLASS';
-}
-my $HARNESS_STRAP_CLASS = $ENV{HARNESS_STRAP_CLASS} || 'Test::Harness::Straps';
-if ( $HARNESS_STRAP_CLASS =~ /\.pm$/ ) {
- # "Class" is actually a filename, that should return the
- # class name as its true return value.
- $HARNESS_STRAP_CLASS = require $HARNESS_STRAP_CLASS;
- if ( !_CLASS($HARNESS_STRAP_CLASS) ) {
- die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name";
- }
-}
-else {
- # It is a class name within the current @INC
- if ( !_CLASS($HARNESS_STRAP_CLASS) ) {
- die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' is not a valid class name";
- }
- eval "require $HARNESS_STRAP_CLASS";
- die $@ if $@;
-}
-if ( !$HARNESS_STRAP_CLASS->isa('Test::Harness::Straps') ) {
- die "HARNESS_STRAP_CLASS '$HARNESS_STRAP_CLASS' must be a Test::Harness::Straps subclass";
-}
-
-$Strap = $HARNESS_STRAP_CLASS->new;
-
-sub strap { return $Strap };
-
-@ISA = ('Exporter');
+@ISA = ('Exporter');
@EXPORT = qw(&runtests);
@EXPORT_OK = qw(&execute_tests $verbose $switches);
-$Verbose = $ENV{HARNESS_VERBOSE} || 0;
-$Debug = $ENV{HARNESS_DEBUG} || 0;
+$Verbose = $ENV{HARNESS_VERBOSE} || 0;
+$Debug = $ENV{HARNESS_DEBUG} || 0;
$Switches = '-w';
-$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
-$Columns--; # Some shells have trouble with a full line of text.
-$Timer = $ENV{HARNESS_TIMER} || 0;
+$Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
+$Columns--; # Some shells have trouble with a full line of text.
+$Timer = $ENV{HARNESS_TIMER} || 0;
=head1 SYNOPSIS
=head1 DESCRIPTION
-B<STOP!> If all you want to do is write a test script, consider
-using Test::Simple. Test::Harness is the module that reads the
-output from Test::Simple, Test::More and other modules based on
-Test::Builder. You don't need to know about Test::Harness to use
-those modules.
-
-Test::Harness runs tests and expects output from the test in a
-certain format. That format is called TAP, the Test Anything
-Protocol. It is defined in L<Test::Harness::TAP>.
-
-C<Test::Harness::runtests(@tests)> runs all the testscripts named
-as arguments and checks standard output for the expected strings
-in TAP format.
+Although, for historical reasons, the L<Test::Harness> distribution
+takes its name from this module it now exists only to provide
+L<TAP::Harness> with an interface that is somewhat backwards compatible
+with L<Test::Harness> 2.xx. If you're writing new code consider using
+L<TAP::Harness> directly instead.
-The F<prove> utility is a thin wrapper around Test::Harness.
+Emulation is provided for C<runtests> and C<execute_tests> but the
+pluggable 'Straps' interface that previous versions of L<Test::Harness>
+supported is not reproduced here. Straps is now available as a stand
+alone module: L<Test::Harness::Straps>.
-=head2 Taint mode
+See L<TAP::Parser> for the main documentation for this distribution.
-Test::Harness will honor the C<-T> or C<-t> in the #! line on your
-test files. So if you begin a test with:
-
- #!perl -T
+=head1 FUNCTIONS
-the test will be run with taint mode on.
+The following functions are available.
-=head2 Configuration variables.
+=head2 runtests( @test_files )
-These variables can be used to configure the behavior of
-Test::Harness. They are exported on request.
+This runs all the given I<@test_files> and divines whether they passed
+or failed based on their output to STDOUT (details above). It prints
+out each individual test which failed along with a summary report and
+a how long it all took.
-=over 4
+It returns true if everything was ok. Otherwise it will C<die()> with
+one of the messages in the DIAGNOSTICS section.
-=item C<$Test::Harness::Verbose>
+=cut
-The package variable C<$Test::Harness::Verbose> is exportable and can be
-used to let C<runtests()> display the standard output of the script
-without altering the behavior otherwise. The F<prove> utility's C<-v>
-flag will set this.
+sub _has_taint {
+ my $test = shift;
+ return TAP::Parser::Source::Perl->get_taint(
+ TAP::Parser::Source::Perl->shebang($test) );
+}
-=item C<$Test::Harness::switches>
+sub _aggregate {
+ my ( $harness, $aggregate, @tests ) = @_;
-The package variable C<$Test::Harness::switches> is exportable and can be
-used to set perl command line options used for running the test
-script(s). The default value is C<-w>. It overrides C<HARNESS_PERL_SWITCHES>.
+ # Don't propagate to our children
+ local $ENV{HARNESS_OPTIONS};
-=item C<$Test::Harness::Timer>
+ if (IS_VMS) {
-If set to true, and C<Time::HiRes> is available, print elapsed seconds
-after each test file.
+ # Jiggery pokery doesn't appear to work on VMS - so disable it
+ # pending investigation.
+ $harness->aggregate_tests( $aggregate, @tests );
+ }
+ else {
+ my $path_sep = $Config{path_sep};
+ my $path_pat = qr{$path_sep};
+ my @extra_inc = _filtered_inc();
+
+ # Supply -I switches in taint mode
+ $harness->callback(
+ parser_args => sub {
+ my ( $args, $test ) = @_;
+ if ( _has_taint( $test->[0] ) ) {
+ push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
+ }
+ }
+ );
-=back
+ my $previous = $ENV{PERL5LIB};
+ local $ENV{PERL5LIB};
+ if ($previous) {
+ push @extra_inc, split( $path_pat, $previous );
+ }
-=head2 Failure
+ if (@extra_inc) {
+ $ENV{PERL5LIB} = join( $path_sep, @extra_inc );
+ }
-When tests fail, analyze the summary report:
+ $harness->aggregate_tests( $aggregate, @tests );
+ }
+}
- t/base..............ok
- t/nonumbers.........ok
- t/ok................ok
- t/test-harness......ok
- t/waterloo..........dubious
- Test returned status 3 (wstat 768, 0x300)
- DIED. FAILED tests 1, 3, 5, 7, 9, 11, 13, 15, 17, 19
- Failed 10/20 tests, 50.00% okay
- Failed Test Stat Wstat Total Fail List of Failed
- ---------------------------------------------------------------
- t/waterloo.t 3 768 20 10 1 3 5 7 9 11 13 15 17 19
- Failed 1/5 test scripts, 80.00% okay. 10/44 subtests failed, 77.27% okay.
+sub runtests {
+ my @tests = @_;
-Everything passed but F<t/waterloo.t>. It failed 10 of 20 tests and
-exited with non-zero status indicating something dubious happened.
+ # shield against -l
+ local ( $\, $, );
-The columns in the summary report mean:
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
-=over 4
+ _aggregate( $harness, $aggregate, @tests );
-=item B<Failed Test>
+ $harness->formatter->summary($aggregate);
-The test file which failed.
+ my $total = $aggregate->total;
+ my $passed = $aggregate->passed;
+ my $failed = $aggregate->failed;
-=item B<Stat>
+ my @parsers = $aggregate->parsers;
-If the test exited with non-zero, this is its exit status.
+ my $num_bad = 0;
+ for my $parser (@parsers) {
+ $num_bad++ if $parser->has_problems;
+ }
-=item B<Wstat>
+ die(sprintf(
+ "Failed %d/%d test programs. %d/%d subtests failed.\n",
+ $num_bad, scalar @parsers, $failed, $total
+ )
+ ) if $num_bad;
-The wait status of the test.
+ return $total && $total == $passed;
+}
-=item B<Total>
+sub _canon {
+ my @list = sort { $a <=> $b } @_;
+ my @ranges = ();
+ my $count = scalar @list;
+ my $pos = 0;
+
+ while ( $pos < $count ) {
+ my $end = $pos + 1;
+ $end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
+ push @ranges, ( $end == $pos + 1 )
+ ? $list[$pos]
+ : join( '-', $list[$pos], $list[ $end - 1 ] );
+ $pos = $end;
+ }
-Total number of tests expected to run.
+ return join( ' ', @ranges );
+}
-=item B<Fail>
+sub _new_harness {
-Number which failed, either from "not ok" or because they never ran.
+ if ( defined( my $env_sw = $ENV{HARNESS_PERL_SWITCHES} ) ) {
+ $Switches .= ' ' . $env_sw if ( length($env_sw) );
+ }
-=item B<List of Failed>
+ # This is a bit crufty. The switches have all been joined into a
+ # single string so we have to try and recover them.
+ my ( @lib, @switches );
+ for my $opt ( split( /\s+(?=-)/, $Switches ) ) {
+ if ( $opt =~ /^ -I (.*) $ /x ) {
+ push @lib, $1;
+ }
+ else {
+ push @switches, $opt;
+ }
+ }
-A list of the tests which failed. Successive failures may be
-abbreviated (ie. 15-20 to indicate that tests 15, 16, 17, 18, 19 and
-20 failed).
+ # Do things the old way on VMS...
+ push @lib, _filtered_inc() if IS_VMS;
+
+ my $args = {
+ timer => $Timer,
+ directives => $Directives,
+ lib => \@lib,
+ switches => \@switches,
+ verbosity => $Verbose,
+ };
+
+ if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
+ for my $opt ( split /:/, $env_opt ) {
+ if ( $opt =~ /^j(\d*)$/ ) {
+ $args->{jobs} = $1 || 9;
+ }
+ elsif ( $opt eq 'f' ) {
+ $args->{fork} = 1;
+ }
+ else {
+ die "Unknown HARNESS_OPTIONS item: $opt\n";
+ }
+ }
+ }
-=back
+ return TAP::Harness->new($args);
+}
+# Get the parts of @INC which are changed from the stock list AND
+# preserve reordering of stock directories.
+sub _filtered_inc {
+ my @inc = grep { !ref } @INC; #28567
-=head1 FUNCTIONS
+ if (IS_VMS) {
-The following functions are available.
+ # VMS has a 255-byte limit on the length of %ENV entries, so
+ # toss the ones that involve perl_root, the install location
+ @inc = grep !/perl_root/i, @inc;
-=head2 runtests( @test_files )
+ }
+ elsif (IS_WIN32) {
-This runs all the given I<@test_files> and divines whether they passed
-or failed based on their output to STDOUT (details above). It prints
-out each individual test which failed along with a summary report and
-a how long it all took.
+ # Lose any trailing backslashes in the Win32 paths
+ s/[\\\/+]$// foreach @inc;
+ }
-It returns true if everything was ok. Otherwise it will C<die()> with
-one of the messages in the DIAGNOSTICS section.
+ my @default_inc = _default_inc();
-=cut
+ my @new_inc;
+ my %seen;
+ for my $dir (@inc) {
+ next if $seen{$dir}++;
-sub runtests {
- my(@tests) = @_;
+ if ( $dir eq ( $default_inc[0] || '' ) ) {
+ shift @default_inc;
+ }
+ else {
+ push @new_inc, $dir;
+ }
- local ($\, $,);
+ shift @default_inc while @default_inc and $seen{ $default_inc[0] };
+ }
- my ($tot, $failedtests,$todo_passed) = execute_tests(tests => \@tests);
- print get_results($tot, $failedtests,$todo_passed);
+ return @new_inc;
+}
- my $ok = _all_ok($tot);
+{
- assert(($ok xor keys %$failedtests),
- q{ok status jives with $failedtests});
+ # Cache this to avoid repeatedly shelling out to Perl.
+ my @inc;
- if (! $ok) {
- die("Failed $tot->{bad}/$tot->{tests} test programs. " .
- "@{[$tot->{max} - $tot->{ok}]}/$tot->{max} subtests failed.\n");
+ sub _default_inc {
+ return @inc if @inc;
+ my $perl = $ENV{HARNESS_PERL} || $^X;
+ chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
+ return @inc;
}
-
- return $ok;
}
-# my $ok = _all_ok(\%tot);
-# Tells you if this test run is overall successful or not.
-
-sub _all_ok {
- my($tot) = shift;
+sub _check_sequence {
+ my @list = @_;
+ my $prev;
+ while ( my $next = shift @list ) {
+ return if defined $prev && $next <= $prev;
+ $prev = $next;
+ }
- return $tot->{bad} == 0 && ($tot->{max} || $tot->{skipped}) ? 1 : 0;
+ return 1;
}
-# Returns all the files in a directory. This is shorthand for backwards
-# compatibility on systems where C<glob()> doesn't work right.
+sub execute_tests {
+ my %args = @_;
-sub _globdir {
- local *DIRH;
+ # TODO: Handle out option
+
+ my $harness = _new_harness();
+ my $aggregate = TAP::Parser::Aggregator->new();
+
+ my %tot = (
+ bonus => 0,
+ max => 0,
+ ok => 0,
+ bad => 0,
+ good => 0,
+ files => 0,
+ tests => 0,
+ sub_skipped => 0,
+ todo => 0,
+ skipped => 0,
+ bench => undef,
+ );
+
+ # Install a callback so we get to see any plans the
+ #Â harness executes.
+ $harness->callback(
+ made_parser => sub {
+ my $parser = shift;
+ $parser->callback(
+ plan => sub {
+ my $plan = shift;
+ if ( $plan->directive eq 'SKIP' ) {
+ $tot{skipped}++;
+ }
+ }
+ );
+ }
+ );
+
+ _aggregate( $harness, $aggregate, @{ $args{tests} } );
+
+ $tot{bench} = $aggregate->elapsed;
+ my @tests = $aggregate->descriptions;
+
+ # TODO: Work out the circumstances under which the files
+ # and tests totals can differ.
+ $tot{files} = $tot{tests} = scalar @tests;
+
+ my %failedtests = ();
+ my %todo_passed = ();
+
+ for my $test (@tests) {
+ my ($parser) = $aggregate->parsers($test);
+
+ my @failed = $parser->failed;
+
+ my $wstat = $parser->wait;
+ my $estat = $parser->exit;
+ my $planned = $parser->tests_planned;
+ my @errors = $parser->parse_errors;
+ my $passed = $parser->passed;
+ my $actual_passed = $parser->actual_passed;
+
+ my $ok_seq = _check_sequence( $parser->actual_passed );
+
+ # Duplicate exit, wait status semantics of old version
+ $estat ||= '' unless $wstat;
+ $wstat ||= '';
+
+ $tot{max} += ( $planned || 0 );
+ $tot{bonus} += $parser->todo_passed;
+ $tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
+ $tot{sub_skipped} += $parser->skipped;
+ $tot{todo} += $parser->todo;
+
+ if ( @failed || $estat || @errors ) {
+ $tot{bad}++;
+
+ my $huh_planned = $planned ? undef : '??';
+ my $huh_errors = $ok_seq ? undef : '??';
+
+ $failedtests{$test} = {
+ 'canon' => $huh_planned
+ || $huh_errors
+ || _canon(@failed)
+ || '??',
+ 'estat' => $estat,
+ 'failed' => $huh_planned
+ || $huh_errors
+ || scalar @failed,
+ 'max' => $huh_planned || $planned,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ else {
+ $tot{good}++;
+ }
- opendir DIRH, shift;
- my @f = readdir DIRH;
- closedir DIRH;
+ my @todo = $parser->todo_passed;
+ if (@todo) {
+ $todo_passed{$test} = {
+ 'canon' => _canon(@todo),
+ 'estat' => $estat,
+ 'failed' => scalar @todo,
+ 'max' => scalar $parser->todo,
+ 'name' => $test,
+ 'wstat' => $wstat
+ };
+ }
+ }
- return @f;
+ return ( \%tot, \%failedtests, \%todo_passed );
}
=head2 execute_tests( tests => \@test_files, out => \*FH )
=cut
-sub execute_tests {
- my %args = @_;
- my @tests = @{$args{tests}};
- my $out = $args{out} || select();
-
- # We allow filehandles that are symbolic refs
- no strict 'refs';
- _autoflush($out);
- _autoflush(\*STDERR);
-
- my %failedtests;
- my %todo_passed;
-
- # Test-wide totals.
- my(%tot) = (
- bonus => 0,
- max => 0,
- ok => 0,
- files => 0,
- bad => 0,
- good => 0,
- tests => scalar @tests,
- sub_skipped => 0,
- todo => 0,
- skipped => 0,
- bench => 0,
- );
-
- my @dir_files;
- @dir_files = _globdir $Files_In_Dir if defined $Files_In_Dir;
- my $run_start_time = new Benchmark;
-
- my $width = _leader_width(@tests);
- foreach my $tfile (@tests) {
- $Last_ML_Print = 0; # so each test prints at least once
- my($leader, $ml) = _mk_leader($tfile, $width);
- local $ML = $ml;
-
- print $out $leader;
-
- $tot{files}++;
-
- $Strap->{_seen_header} = 0;
- if ( $Test::Harness::Debug ) {
- print $out "# Running: ", $Strap->_command_line($tfile), "\n";
- }
- my $test_start_time = $Timer ? time : 0;
- my $results = $Strap->analyze_file($tfile) or
- do { warn $Strap->{error}, "\n"; next };
- my $elapsed;
- if ( $Timer ) {
- $elapsed = time - $test_start_time;
- if ( $has_time_hires ) {
- $elapsed = sprintf( " %8d ms", $elapsed*1000 );
- }
- else {
- $elapsed = sprintf( " %8s s", $elapsed ? $elapsed : "<1" );
- }
- }
- else {
- $elapsed = "";
- }
-
- # state of the current test.
- my @failed = grep { !$results->details->[$_-1]{ok} }
- 1..@{$results->details};
- my @todo_pass = grep { $results->details->[$_-1]{actual_ok} &&
- $results->details->[$_-1]{type} eq 'todo' }
- 1..@{$results->details};
-
- my %test = (
- ok => $results->ok,
- 'next' => $Strap->{'next'},
- max => $results->max,
- failed => \@failed,
- todo_pass => \@todo_pass,
- todo => $results->todo,
- bonus => $results->bonus,
- skipped => $results->skip,
- skip_reason => $results->skip_reason,
- skip_all => $Strap->{skip_all},
- ml => $ml,
- );
-
- $tot{bonus} += $results->bonus;
- $tot{max} += $results->max;
- $tot{ok} += $results->ok;
- $tot{todo} += $results->todo;
- $tot{sub_skipped} += $results->skip;
-
- my $estatus = $results->exit;
- my $wstatus = $results->wait;
-
- if ( $results->passing ) {
- # XXX Combine these first two
- if ($test{max} and $test{skipped} + $test{bonus}) {
- my @msg;
- push(@msg, "$test{skipped}/$test{max} skipped: $test{skip_reason}")
- if $test{skipped};
- if ($test{bonus}) {
- my ($txt, $canon) = _canondetail($test{todo},0,'TODO passed',
- @{$test{todo_pass}});
- $todo_passed{$tfile} = {
- canon => $canon,
- max => $test{todo},
- failed => $test{bonus},
- name => $tfile,
- estat => '',
- wstat => '',
- };
-
- push(@msg, "$test{bonus}/$test{max} unexpectedly succeeded\n$txt");
- }
- print $out "$test{ml}ok$elapsed\n ".join(', ', @msg)."\n";
- }
- elsif ( $test{max} ) {
- print $out "$test{ml}ok$elapsed\n";
- }
- elsif ( defined $test{skip_all} and length $test{skip_all} ) {
- print $out "skipped\n all skipped: $test{skip_all}\n";
- $tot{skipped}++;
- }
- else {
- print $out "skipped\n all skipped: no reason given\n";
- $tot{skipped}++;
- }
- $tot{good}++;
- }
- else {
- # List unrun tests as failures.
- if ($test{'next'} <= $test{max}) {
- push @{$test{failed}}, $test{'next'}..$test{max};
- }
- # List overruns as failures.
- else {
- my $details = $results->details;
- foreach my $overrun ($test{max}+1..@$details) {
- next unless ref $details->[$overrun-1];
- push @{$test{failed}}, $overrun
- }
- }
-
- if ($wstatus) {
- $failedtests{$tfile} = _dubious_return(\%test, \%tot,
- $estatus, $wstatus);
- $failedtests{$tfile}{name} = $tfile;
- }
- elsif ( $results->seen ) {
- if (@{$test{failed}} and $test{max}) {
- my ($txt, $canon) = _canondetail($test{max},$test{skipped},'Failed',
- @{$test{failed}});
- print $out "$test{ml}$txt";
- $failedtests{$tfile} = { canon => $canon,
- max => $test{max},
- failed => scalar @{$test{failed}},
- name => $tfile,
- estat => '',
- wstat => '',
- };
- }
- else {
- print $out "Don't know which tests failed: got $test{ok} ok, ".
- "expected $test{max}\n";
- $failedtests{$tfile} = { canon => '??',
- max => $test{max},
- failed => '??',
- name => $tfile,
- estat => '',
- wstat => '',
- };
- }
- $tot{bad}++;
- }
- else {
- print $out "FAILED before any test output arrived\n";
- $tot{bad}++;
- $failedtests{$tfile} = { canon => '??',
- max => '??',
- failed => '??',
- name => $tfile,
- estat => '',
- wstat => '',
- };
- }
- }
-
- if (defined $Files_In_Dir) {
- my @new_dir_files = _globdir $Files_In_Dir;
- if (@new_dir_files != @dir_files) {
- my %f;
- @f{@new_dir_files} = (1) x @new_dir_files;
- delete @f{@dir_files};
- my @f = sort keys %f;
- print $out "LEAKED FILES: @f\n";
- @dir_files = @new_dir_files;
- }
- }
- } # foreach test
- $tot{bench} = timediff(new Benchmark, $run_start_time);
-
- $Strap->_restore_PERL5LIB;
-
- return(\%tot, \%failedtests, \%todo_passed);
-}
-
-# Turns on autoflush for the handle passed
-sub _autoflush {
- my $flushy_fh = shift;
- my $old_fh = select $flushy_fh;
- $| = 1;
- select $old_fh;
-}
-
-=for private _mk_leader
-
- my($leader, $ml) = _mk_leader($test_file, $width);
-
-Generates the 't/foo........' leader for the given C<$test_file> as well
-as a similar version which will overwrite the current line (by use of
-\r and such). C<$ml> may be empty if Test::Harness doesn't think you're
-on TTY.
-
-The C<$width> is the width of the "yada/blah.." string.
-
-=cut
-
-sub _mk_leader {
- my($te, $width) = @_;
- chomp($te);
- $te =~ s/\.\w+$/./;
-
- if ($^O eq 'VMS') {
- $te =~ s/^.*\.t\./\[.t./s;
- }
- my $leader = "$te" . '.' x ($width - length($te));
- my $ml = "";
-
- if ( -t STDOUT and not $ENV{HARNESS_NOTTY} and not $Verbose ) {
- $ml = "\r" . (' ' x 77) . "\r$leader"
- }
-
- return($leader, $ml);
-}
-
-=for private _leader_width
-
- my($width) = _leader_width(@test_files);
-
-Calculates how wide the leader should be based on the length of the
-longest test name.
-
-=cut
-
-sub _leader_width {
- my $maxlen = 0;
- my $maxsuflen = 0;
- foreach (@_) {
- my $suf = /\.(\w+)$/ ? $1 : '';
- my $len = length;
- my $suflen = length $suf;
- $maxlen = $len if $len > $maxlen;
- $maxsuflen = $suflen if $suflen > $maxsuflen;
- }
- # + 3 : we want three dots between the test name and the "ok"
- return $maxlen + 3 - $maxsuflen;
-}
-
-sub get_results {
- my $tot = shift;
- my $failedtests = shift;
- my $todo_passed = shift;
-
- my $out = '';
-
- my $bonusmsg = _bonusmsg($tot);
-
- if (_all_ok($tot)) {
- $out .= "All tests successful$bonusmsg.\n";
- if ($tot->{bonus}) {
- my($fmt_top, $fmt) = _create_fmts("Passed TODO",$todo_passed);
- # Now write to formats
- $out .= swrite( $fmt_top );
- for my $script (sort keys %{$todo_passed||{}}) {
- my $Curtest = $todo_passed->{$script};
- $out .= swrite( $fmt, @{ $Curtest }{qw(name estat wstat max failed canon)} );
- }
- }
- }
- elsif (!$tot->{tests}){
- die "FAILED--no tests were run for some reason.\n";
- }
- elsif (!$tot->{max}) {
- my $blurb = $tot->{tests}==1 ? "script" : "scripts";
- die "FAILED--$tot->{tests} test $blurb could be run, ".
- "alas--no output ever seen\n";
- }
- else {
- my $subresults = sprintf( " %d/%d subtests failed.",
- $tot->{max} - $tot->{ok}, $tot->{max} );
-
- my($fmt_top, $fmt1, $fmt2) = _create_fmts("Failed Test",$failedtests);
-
- # Now write to formats
- $out .= swrite( $fmt_top );
- for my $script (sort keys %$failedtests) {
- my $Curtest = $failedtests->{$script};
- $out .= swrite( $fmt1, @{ $Curtest }{qw(name estat wstat max failed canon)} );
- $out .= swrite( $fmt2, $Curtest->{canon} );
- }
- if ($tot->{bad}) {
- $bonusmsg =~ s/^,\s*//;
- $out .= "$bonusmsg.\n" if $bonusmsg;
- $out .= "Failed $tot->{bad}/$tot->{tests} test scripts.$subresults\n";
- }
- }
-
- $out .= sprintf("Files=%d, Tests=%d, %s\n",
- $tot->{files}, $tot->{max}, timestr($tot->{bench}, 'nop'));
- return $out;
-}
-
-sub swrite {
- my $format = shift;
- $^A = '';
- formline($format,@_);
- my $out = $^A;
- $^A = '';
- return $out;
-}
-
-
-my %Handlers = (
- header => \&header_handler,
- test => \&test_handler,
- bailout => \&bailout_handler,
-);
-
-$Strap->set_callback(\&strap_callback);
-sub strap_callback {
- my($self, $line, $type, $totals) = @_;
- print $line if $Verbose;
-
- my $meth = $Handlers{$type};
- $meth->($self, $line, $type, $totals) if $meth;
-};
-
-
-sub header_handler {
- my($self, $line, $type, $totals) = @_;
-
- warn "Test header seen more than once!\n" if $self->{_seen_header};
-
- $self->{_seen_header}++;
-
- warn "1..M can only appear at the beginning or end of tests\n"
- if $totals->seen && ($totals->max < $totals->seen);
-};
-
-sub test_handler {
- my($self, $line, $type, $totals) = @_;
-
- my $curr = $totals->seen;
- my $next = $self->{'next'};
- my $max = $totals->max;
- my $detail = $totals->details->[-1];
-
- if( $detail->{ok} ) {
- _print_ml_less("ok $curr/$max");
-
- if( $detail->{type} eq 'skip' ) {
- $totals->set_skip_reason( $detail->{reason} )
- unless defined $totals->skip_reason;
- $totals->set_skip_reason( 'various reasons' )
- if $totals->skip_reason ne $detail->{reason};
- }
- }
- else {
- _print_ml("NOK $curr/$max");
- }
-
- if( $curr > $next ) {
- print "Test output counter mismatch [test $curr]\n";
- }
- elsif( $curr < $next ) {
- print "Confused test output: test $curr answered after ".
- "test ", $next - 1, "\n";
- }
-
-};
-
-sub bailout_handler {
- my($self, $line, $type, $totals) = @_;
-
- die "FAILED--Further testing stopped" .
- ($self->{bailout_reason} ? ": $self->{bailout_reason}\n" : ".\n");
-};
-
-
-sub _print_ml {
- print join '', $ML, @_ if $ML;
-}
-
-
-# Print updates only once per second.
-sub _print_ml_less {
- my $now = CORE::time;
- if ( $Last_ML_Print != $now ) {
- _print_ml(@_);
- $Last_ML_Print = $now;
- }
-}
-
-sub _bonusmsg {
- my($tot) = @_;
-
- my $bonusmsg = '';
- $bonusmsg = (" ($tot->{bonus} subtest".($tot->{bonus} > 1 ? 's' : '').
- " UNEXPECTEDLY SUCCEEDED)")
- if $tot->{bonus};
-
- if ($tot->{skipped}) {
- $bonusmsg .= ", $tot->{skipped} test"
- . ($tot->{skipped} != 1 ? 's' : '');
- if ($tot->{sub_skipped}) {
- $bonusmsg .= " and $tot->{sub_skipped} subtest"
- . ($tot->{sub_skipped} != 1 ? 's' : '');
- }
- $bonusmsg .= ' skipped';
- }
- elsif ($tot->{sub_skipped}) {
- $bonusmsg .= ", $tot->{sub_skipped} subtest"
- . ($tot->{sub_skipped} != 1 ? 's' : '')
- . " skipped";
- }
- return $bonusmsg;
-}
-
-# Test program go boom.
-sub _dubious_return {
- my($test, $tot, $estatus, $wstatus) = @_;
-
- my $failed = '??';
- my $canon = '??';
-
- printf "$test->{ml}dubious\n\tTest returned status $estatus ".
- "(wstat %d, 0x%x)\n",
- $wstatus,$wstatus;
- print "\t\t(VMS status is $estatus)\n" if $^O eq 'VMS';
-
- $tot->{bad}++;
-
- if ($test->{max}) {
- if ($test->{'next'} == $test->{max} + 1 and not @{$test->{failed}}) {
- print "\tafter all the subtests completed successfully\n";
- $failed = 0; # But we do not set $canon!
- }
- else {
- push @{$test->{failed}}, $test->{'next'}..$test->{max};
- $failed = @{$test->{failed}};
- (my $txt, $canon) = _canondetail($test->{max},$test->{skipped},'Failed',@{$test->{failed}});
- print "DIED. ",$txt;
- }
- }
-
- return { canon => $canon, max => $test->{max} || '??',
- failed => $failed,
- estat => $estatus, wstat => $wstatus,
- };
-}
-
-
-sub _create_fmts {
- my $failed_str = shift;
- my $failedtests = shift;
-
- my ($type) = split /\s/,$failed_str;
- my $short = substr($type,0,4);
- my $total = $short eq 'Pass' ? 'TODOs' : 'Total';
- my $middle_str = " Stat Wstat $total $short ";
- my $list_str = "List of $type";
-
- # Figure out our longest name string for formatting purposes.
- my $max_namelen = length($failed_str);
- foreach my $script (keys %$failedtests) {
- my $namelen = length $failedtests->{$script}->{name};
- $max_namelen = $namelen if $namelen > $max_namelen;
- }
-
- my $list_len = $Columns - length($middle_str) - $max_namelen;
- if ($list_len < length($list_str)) {
- $list_len = length($list_str);
- $max_namelen = $Columns - length($middle_str) - $list_len;
- if ($max_namelen < length($failed_str)) {
- $max_namelen = length($failed_str);
- $Columns = $max_namelen + length($middle_str) + $list_len;
- }
- }
-
- my $fmt_top = sprintf("%-${max_namelen}s", $failed_str)
- . $middle_str
- . $list_str . "\n"
- . "-" x $Columns
- . "\n";
-
- my $fmt1 = "@" . "<" x ($max_namelen - 1)
- . " @>> @>>>> @>>>> @>>> "
- . "^" . "<" x ($list_len - 1) . "\n";
- my $fmt2 = "~~" . " " x ($Columns - $list_len - 2) . "^"
- . "<" x ($list_len - 1) . "\n";
-
- return($fmt_top, $fmt1, $fmt2);
-}
-
-sub _canondetail {
- my $max = shift;
- my $skipped = shift;
- my $type = shift;
- my @detail = @_;
- my %seen;
- @detail = sort {$a <=> $b} grep !$seen{$_}++, @detail;
- my $detail = @detail;
- my @result = ();
- my @canon = ();
- my $min;
- my $last = $min = shift @detail;
- my $canon;
- my $uc_type = uc($type);
- if (@detail) {
- for (@detail, $detail[-1]) { # don't forget the last one
- if ($_ > $last+1 || $_ == $last) {
- push @canon, ($min == $last) ? $last : "$min-$last";
- $min = $_;
- }
- $last = $_;
- }
- local $" = ", ";
- push @result, "$uc_type tests @canon\n";
- $canon = join ' ', @canon;
- }
- else {
- push @result, "$uc_type test $last\n";
- $canon = $last;
- }
-
- return (join("", @result), $canon)
- if $type=~/todo/i;
- push @result, "\t$type $detail/$max tests, ";
- if ($max) {
- push @result, sprintf("%.2f",100*(1-$detail/$max)), "% okay";
- }
- else {
- push @result, "?% okay";
- }
- my $ender = 's' x ($skipped > 1);
- if ($skipped) {
- my $good = $max - $detail - $skipped;
- my $skipmsg = " (less $skipped skipped test$ender: $good okay, ";
- if ($max) {
- my $goodper = sprintf("%.2f",100*($good/$max));
- $skipmsg .= "$goodper%)";
- }
- else {
- $skipmsg .= "?%)";
- }
- push @result, $skipmsg;
- }
- push @result, "\n";
- my $txt = join "", @result;
- return ($txt, $canon);
-}
-
1;
__END__
-
=head1 EXPORT
-C<&runtests> is exported by Test::Harness by default.
+C<&runtests> is exported by C<Test::Harness> by default.
C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
exported upon request.
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item C<All tests successful.\nFiles=%d, Tests=%d, %s>
-
-If all tests are successful some statistics about the performance are
-printed.
-
-=item C<FAILED tests %s\n\tFailed %d/%d tests, %.2f%% okay.>
-
-For any single script that has failing subtests statistics like the
-above are printed.
-
-=item C<Test returned status %d (wstat %d)>
-
-Scripts that return a non-zero exit status, both C<$? E<gt>E<gt> 8>
-and C<$?> are printed in a message similar to the above.
-
-=item C<Failed 1 test, %.2f%% okay. %s>
-
-=item C<Failed %d/%d tests, %.2f%% okay. %s>
-
-If not all tests were successful, the script dies with one of the
-above messages.
-
-=item C<FAILED--Further testing stopped: %s>
-
-If a single subtest decides that further testing will not make sense,
-the script dies with this message.
-
-=back
-
-=head1 ENVIRONMENT VARIABLES THAT TEST::HARNESS SETS
+=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
-Test::Harness sets these before executing the individual tests.
+C<Test::Harness> sets these before executing the individual tests.
=over 4
=item C<HARNESS_VERSION>
-This is the version of Test::Harness.
+This is the version of C<Test::Harness>.
=back
=over 4
-=item C<HARNESS_COLUMNS>
-
-This value will be used for the width of the terminal. If it is not
-set then it will default to C<COLUMNS>. If this is not set, it will
-default to 80. Note that users of Bourne-sh based shells will need to
-C<export COLUMNS> for this module to use that variable.
-
-=item C<HARNESS_COMPILE_TEST>
-
-When true it will make harness attempt to compile the test using
-C<perlcc> before running it.
-
-B<NOTE> This currently only works when sitting in the perl source
-directory!
-
-=item C<HARNESS_DEBUG>
-
-If true, Test::Harness will print debugging information about itself as
-it runs the tests. This is different from C<HARNESS_VERBOSE>, which prints
-the output from the test being run. Setting C<$Test::Harness::Debug> will
-override this, or you can use the C<-d> switch in the F<prove> utility.
-
-=item C<HARNESS_FILELEAK_IN_DIR>
-
-When set to the name of a directory, harness will check after each
-test whether new files appeared in that directory, and report them as
-
- LEAKED FILES: scr.tmp 0 my.db
-
-If relative, directory name is with respect to the current directory at
-the moment runtests() was called. Putting absolute path into
-C<HARNESS_FILELEAK_IN_DIR> may give more predictable results.
-
-=item C<HARNESS_NOTTY>
-
-When set to a true value, forces it to behave as though STDOUT were
-not a console. You may need to set this if you don't want harness to
-output more frequent progress messages using carriage returns. Some
-consoles may not handle carriage returns properly (which results in a
-somewhat messy output).
-
-=item C<HARNESS_PERL>
-
-Usually your tests will be run by C<$^X>, the currently-executing Perl.
-However, you may want to have it run by a different executable, such as
-a threading perl, or a different version.
-
-If you're using the F<prove> utility, you can use the C<--perl> switch.
-
-=item C<HARNESS_PERL_SWITCHES>
-
-Its value will be prepended to the switches used to invoke perl on
-each test. For example, setting C<HARNESS_PERL_SWITCHES> to C<-W> will
-run all tests with all warnings enabled.
-
=item C<HARNESS_TIMER>
Setting this to true will make the harness display the number of
=item C<HARNESS_VERBOSE>
-If true, Test::Harness will output the verbose results of running
-its tests. Setting C<$Test::Harness::verbose> will override this,
-or you can use the C<-v> switch in the F<prove> utility.
-
-If true, Test::Harness will output the verbose results of running
+If true, C<Test::Harness> will output the verbose results of running
its tests. Setting C<$Test::Harness::verbose> will override this,
or you can use the C<-v> switch in the F<prove> utility.
-=item C<HARNESS_STRAP_CLASS>
+=item C<HARNESS_OPTIONS>
-Defines the Test::Harness::Straps subclass to use. The value may either
-be a filename or a class name.
+Provide additional options to the harness. Currently supported options are:
-If HARNESS_STRAP_CLASS is a class name, the class must be in C<@INC>
-like any other class.
+=over
-If HARNESS_STRAP_CLASS is a filename, the .pm file must return the name
-of the class, instead of the canonical "1".
+=item C<< j<n> >>
-=back
-
-=head1 EXAMPLE
-
-Here's how Test::Harness tests itself
-
- $ cd ~/src/devel/Test-Harness
- $ perl -Mblib -e 'use Test::Harness qw(&runtests $verbose);
- $verbose=0; runtests @ARGV;' t/*.t
- Using /home/schwern/src/devel/Test-Harness/blib
- t/base..............ok
- t/nonumbers.........ok
- t/ok................ok
- t/test-harness......ok
- All tests successful.
- Files=4, Tests=24, 2 wallclock secs ( 0.61 cusr + 0.41 csys = 1.02 CPU)
-
-=head1 SEE ALSO
-
-The included F<prove> utility for running test scripts from the command line,
-L<Test> and L<Test::Simple> for writing test scripts, L<Benchmark> for
-the underlying timing routines, and L<Devel::Cover> for test coverage
-analysis.
-
-=head1 TODO
-
-Provide a way of running tests quietly (ie. no printing) for automated
-validation of tests. This will probably take the form of a version
-of runtests() which rather than printing its output returns raw data
-on the state of the tests. (Partially done in Test::Harness::Straps)
-
-Document the format.
-
-Fix HARNESS_COMPILE_TEST without breaking its core usage.
+Run <n> (default 9) parallel jobs.
-Figure a way to report test names in the failure summary.
+=item C<< f >>
-Rework the test summary so long test names are not truncated as badly.
-(Partially done with new skip test styles)
+Use forked parallelism.
-Add option for coverage analysis.
-
-Trap STDERR.
-
-Implement Straps total_results()
-
-Remember exit code
-
-Completely redo the print summary code.
-
-Straps->analyze_file() not taint clean, don't know if it can be
-
-Fix that damned VMS nit.
-
-Add a test for verbose.
+=back
-Change internal list of test results to a hash.
+Multiple options may be separated by colons:
-Fix stats display when there's an overrun.
+ HARNESS_OPTIONS=j9:f make test
-Fix so perls with spaces in the filename work.
+=back
-Keeping whittling away at _run_all_tests()
+=head1 SEE ALSO
-Clean up how the summary is printed. Get rid of those damned formats.
+L<TAP::Harness>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-test-harness at rt.cpan.org>, or through the web interface at
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>.
-I will be notified, and then you'll automatically be notified of progress on
-your bug as I make changes.
-
-=head1 SUPPORT
-
-You can find documentation for this module with the F<perldoc> command.
-
- perldoc Test::Harness
-
-You can get docs for F<prove> with
-
- prove --man
-
-You can also look for information at:
-
-=over 4
-
-=item * AnnoCPAN: Annotated CPAN documentation
-
-L<http://annocpan.org/dist/Test-Harness>
-
-=item * CPAN Ratings
-
-L<http://cpanratings.perl.org/d/Test-Harness>
-
-=item * RT: CPAN's request tracker
-
-L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Harness>
-
-=item * Search CPAN
-
-L<http://search.cpan.org/dist/Test-Harness>
-
-=back
-
-=head1 SOURCE CODE
-
-The source code repository for Test::Harness is at
-L<http://svn.perl.org/modules/Test-Harness>.
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
+notified, and then you'll automatically be notified of progress on your bug
+as I make changes.
=head1 AUTHORS
-Either Tim Bunce or Andreas Koenig, we don't know. What we know for
-sure is, that it was inspired by Larry Wall's F<TEST> script that came
-with perl distributions for ages. Numerous anonymous contributors
-exist. Andreas Koenig held the torch for many years, and then
-Michael G Schwern.
+Andy Armstrong C<< <andy@hexten.net> >>
-Current maintainer is Andy Lester C<< <andy at petdance.com> >>.
+L<Test::Harness> (on which this module is based) has this attribution:
-=head1 COPYRIGHT
+ Either Tim Bunce or Andreas Koenig, we don't know. What we know for
+ sure is, that it was inspired by Larry Wall's F<TEST> script that came
+ with perl distributions for ages. Numerous anonymous contributors
+ exist. Andreas Koenig held the torch for many years, and then
+ Michael G Schwern.
-Copyright 2002-2006
-by Michael G Schwern C<< <schwern at pobox.com> >>,
-Andy Lester C<< <andy at petdance.com> >>.
+=head1 LICENCE AND COPYRIGHT
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+Copyright (c) 2007, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
-See L<http://www.perl.com/perl/misc/Artistic.html>.
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
-=cut
+++ /dev/null
-package Test::Harness::Assert;
-
-use strict;
-require Exporter;
-use vars qw($VERSION @EXPORT @ISA);
-
-$VERSION = '0.02';
-
-@ISA = qw(Exporter);
-@EXPORT = qw(assert);
-
-
-=head1 NAME
-
-Test::Harness::Assert - simple assert
-
-=head1 SYNOPSIS
-
- ### FOR INTERNAL USE ONLY ###
-
- use Test::Harness::Assert;
-
- assert( EXPR, $name );
-
-=head1 DESCRIPTION
-
-A simple assert routine since we don't have Carp::Assert handy.
-
-B<For internal use by Test::Harness ONLY!>
-
-=head1 FUNCTIONS
-
-=head2 C<assert()>
-
- assert( EXPR, $name );
-
-If the expression is false the program aborts.
-
-=cut
-
-sub assert ($;$) {
- my($assert, $name) = @_;
-
- unless( $assert ) {
- require Carp;
- my $msg = 'Assert failed';
- $msg .= " - '$name'" if defined $name;
- $msg .= '!';
- Carp::croak($msg);
- }
-
-}
-
-=head1 AUTHOR
-
-Michael G Schwern C<< <schwern at pobox.com> >>
-
-=head1 SEE ALSO
-
-L<Carp::Assert>
-
-=cut
-
-1;
-Revision history for Perl extension Test::Harness
-
-NEXT
- [FIXES]
- * prove's --perl=/path/to/file wasn't taking a value.
- * prove's version number was not getting incremented. From now on,
- prove's $VERSION will match Test::Harness's $VERSION, and I added
- a test to make sure this is the case.
-
- [ENHANCEMENTS]
- * Added test straps overload via HARNESS_STRAP_OVERLOAD environment
- variable. prove now takes a --strap=class parameter. Thanks,
- Adam Kennedy.
-
-2.63_01 Fri Jun 30 16:59:50 CDT 2006
- [ENHANCEMENTS]
- * Failed tests used to say "NOK x", and now say "NOK x/y".
- Thanks to Will Coleda.
-
- * Added the Test::Harness::Results object, so we have a well-defined
- object, and not just a hash that we pass around. Thanks to YAPC::NA
- 2006 Hackathon!
-
-2.62 Thu Jun 8 14:11:57 CDT 2006
- [FIXES]
- * Restored the behavior of dying if any subtests failed. This is a
- pretty crucial bug that I should have fixed long ago. Not having this
- means that CPANPLUS will install modules even if their tests fail. :-(
-
-2.60 Wed May 24 14:48:44 CDT 2006
- [FIXES]
- * Fixed the headers in the summary failure table.
-
-2.58 Sat May 13 22:53:53 CDT 2006
- No changes. Released to the world with a non-beta number.
-
-2.57_06 Sun Apr 23 00:55:43 CDT 2006
- [THINGS THAT MIGHT BREAK YOUR CODE]
- * Anything that displays a percentage of tests passed has been
- removed. Output at the end of failing runs is now different.
-
- [FIXES]
- * Fixed the TODO-passing patch from 2.57_05.
-
- [ENHANCEMENTS]
- * The unnecessary display of percentages of tests passing and failing
- have been removed. Tests are not a percentage game.
-
- * Caches the results of _default_inc(), which is expensive because
- of shelling out to get the pathnames. Benchmarking was showing that
- 15% of Test::Harness's time was spent in this function. For test
- suites with many test files, this can be significant. With this
- speedup, the "make test" for the Perl core speeds up 2.5%.
- Thanks to Nicholas Clark for finding this.
-
- [DOCUMENTATION]
- * Fixed HARNESS_PERL_SWITCHES typo. Thanks, Andreas Koenig.
-
- * Added docs on HARNESS_TIMER and --timer. Thanks, Mike O'Regan.
-
-2.57_05 Wed Apr 19 00:31:10 CDT 2006
- [ENHANCEMENTS]
- * Now shows details of the tests that unexpectedly pass, instead of
- just giving a number. Thanks, demerphq!
-
- [INTERNALS]
- * Fixed globbing to work under Perls before 5.6.0. Before Perl 5.6.0,
- prove just uses the internal glob() function.
-
-2.57_04 Mon Apr 17 13:35:10 CDT 2006
- [ENHANCEMENTS]
- * prove's globbing is now done with File::Glob::bsd_glob().
- Otherwise, "prove c:\program files\svk\t\*" fails because glob()
- considers it to be two patterns, splitting on whitespace. Thanks to
- Audrey Tang.
-
- [DOCUMENTATION]
- * Added information about other TAP implementations in other languages.
-
-2.57_03 Dec 31 2005
-
- [THINGS THAT MAY BREAK YOUR CODE]
- * Internal functions _run_all_tests() and _show_results() no longer
- exist. You shouldn't have been using them anyway since they're
- prepended with underscores.
-
- [INTERNALS]
- * Added the ability to send test output to a filehandle of
- one's choosing. Two internal functions are now exposed:
- execute_tests() and get_results() (formerly _run_all_tests() and
- _show_results()). This should allow CPANPLUS to work properly
- with Module::Build. Thanks to Ken Williams.
-
- [DOCUMENTATION]
- * Hid the documentation for the private methods in Test::Harness::Straps.
-
-2.57_02 Fri Dec 30 23:51:17 CST 2005
- [THINGS THAT MAY BREAK YOUR CODE]
- * prove's --ext option has been removed. I'm betting that nobody used it.
-
- [ENHANCEMENTS]
- * prove can now take -w and -W switches, analogous to those in perl.
- This means that "prove -wlb t/*.t" is exactly the same as "make test".
- Thanks to Rob Kinyon.
- * Started a Test::Harness::Util module for code that may be reused
- by other Harness-using modules.
-
- [INTERNALS]
- * The t/prove*.t tests now use $^X to call prove. Thanks to Yves Orton.
- * Test::Harness::Straps no longer uses Win32::GetShortPathName().
- Thanks to Gisle Aas.
-
-2.57_01 Mon Dec 26 01:39:07 CST 2005
- [FIXES]
- * Removed code and docs mentioning HARNESS_IGNORE_EXITCODE, which
- is not used anywhere.
-
- [ENHANCEMENTS]
- * If we have hi-res timings, then they're shown in integer
- milliseconds, rather than fractional seconds.
-
- * Added the --perl switch to prove.
-
- [DOCUMENTATION]
- * Added links to CPAN support sites.
-
-2.56 Wed Sep 28 16:04:00 CDT 2005
- [FIXES]
- * Incorporate bleadperl patch to fix Test::Harness on VMS.
-
-2.54 Wed Sep 28 09:52:19 CDT 2005
- [FIXES]
- * Test counts were wrong, so wouldn't install on Perls < 5.8.0.
-
-2.53_02 Thu Aug 25 21:37:01 CDT 2005
- [FIXES]
- * File order in prove is now sorted within the directory. It's not
- the sorting that's important as much as the deterministic results.
- Thanks to Adam Kennedy and Casey West for pointing this out,
- independently of each other, with 12 hours of the other.
-
- [INTERNALS]
- * Fix calls to podusage() to not use the DATA typeglob. Thanks sungo.
-
-2.53_01 Sun Jul 10 10:45:27 CDT 2005
- [FIXES]
- * If we go over 100,000 tests, it used to print out a warning for
- every test over 100,000. Now, we stop after the first. Thanks to
- Sebastien Aperghis-Tramoni.
-
-2.52 Sun Jun 26 23:05:19 CDT 2005
- No changes
-
-2.51_02
- [ENHANCEMENTS]
- * The Test::Harness timer is now off by default. Set HARNESS_TIMER
- true if you want it. Added --timer flag to prove.
-
-2.50_01
- [FIXES]
- * Call CORE::time() to figure out if we should print when we're
- printing once per second. Otherwise, we're using Time::HiRes'
- version of it. Thanks, Nicholas Clark.
-
-2.50 Tue Jun 21 14:32:12 CDT 2005
- [FIXES]
- * Added some includes in t/strap-analyze.t to make Cygwin happy.
-
-2.49_02 Tue Jun 21 09:54:44 CDT 2005
- [FIXES]
- * Added some includes in t/test_harness.t to make Cygwin happy.
-
-2.49_01 Fri Jun 10 15:37:31 CDT 2005
- [ENHANCEMENTS]
- * Now shows elapsed time in 1000ths of a second if Time::HiRes
- is available.
-
- [FIXES]
- * Test::Harness::Iterator didn't have a 1; at the end. Thanks to
- Steve Peters for finding it.
-
-2.48 Fri Apr 22 22:41:46 CDT 2005
- Released after weeks of non-complaint.
-
-2.47_03 Wed Mar 2 16:52:55 CST 2005
- [THINGS THAT MIGHT BREAK YOUR CODE]
- * Test::Harness now requires Perl 5.005_03 or above.
-
- [FIXES]
- * Fixed incorrect "confused by tests in wrong order" error in 2.47_02.
-
-2.47_02 Tue Mar 1 23:15:47 CST 2005
- [THINGS THAT MIGHT BREAK YOUR CODE]
- * Test directives for skip tests used to be anything that matches
- /^skip/i, like the word "skipped", but now it must match
- /^skip\s+/i.
-
- [ENHANCEMENTS]
- * T::H now sets environment variable HARNESS_VERSION, in case a test
- program wants to know what version of T::H it's running under.
-
-2.47_01 Mon Feb 21 01:14:13 CST 2005
- [FIXES]
- * Fixed a problem submitted by Craig Berry:
-
- Several of the Test::Harness tests now fail on VMS with the
- following warning:
-
- Can't find string terminator "]" anywhere before EOF at -e line 1.
-
- The problem is that when a command is piped to the shell and that
- command has a newline character embedded in it, the part after
- the newline is invisible to the shell. The patch below corrects
- that by escaping the newline so it is not subject to variable
- interpolation until it gets to the child's Perl one-liner.
-
- [ENHANCEMENTS]
- * Test::Harness::Straps now has diagnostic gathering without changing
- how tests are run. It also adds these messages by default.
- Note that the new method, _is_diagnostic(), is for internal
- use only. It may change soon. Thanks to chromatic.
-
- [DOCUMENTATION]
- * Expanded Test::Harness::TAP.pod, and added examples.
-
- * Fixed a crucial documentation typo in Test::Harness::Straps.
-
-2.46 Thu Jan 20 11:50:59 CST 2005
- Released.
-
-2.45_02 Fri Dec 31 14:57:33 CST 2004
- [ENHANCEMENTS]
- * Turns off buffering on both STDERR and STDOUT, so that the two
- output handles don't get out of sync with each other. Thanks to
- David Wheeler.
-
- * No longer requires, or supports, the HARNESS_OK_SLOW environment
- variable. Test counts are only updated once per second, which
- used to require having HARNESS_OK_SLOW set.
-
-2.45_01 Fri Dec 17 22:39:17 CST 2004
- [THINGS THAT MIGHT BREAK YOUR CODE]
- * Test::Harness now requires Perl 5.004_05.
-
- * We no longer try to print a stack if a coredump is detected.
-
- [FIXES]
- * Reverted Test::Harness::Iterator::next()'s use of readline, since
- it fails under Perl 5.5.4.
-
- * We no longer try to print a stack if a coredump is detected.
- This means that the external problems we've had with wait.ph
- now disappear. This resolves a number of problems that various
- Linux distros have, and closes a couple of RT tickets like #2729
- and #7716.
-
- [ENHANCEMENTS]
- * Added Test::Harness->strap() method to access the internal strap.
-
- [DOCUMENTATION]
- * Obfuscated the rt.cpan.org email address. The damage is already
- done, but at least we'll have it hidden going forward.
-
-2.44 Tue Nov 30 18:38:17 CST 2004
- [INTERNALS]
- * De-anonymized the callbacks and handlers in Test::Harness, mostly
- so I can profile better.
-
- * Checks _is_header() only if _is_line() fails first. No point
- in checking every line of the input for something that can only
- occur once.
-
- * Inline the _detailize() function, which was getting called once
- per line of input. Reduced execution time about 5-7%.
-
- * Removed unnecessary temporary variables in Test::Harness::Straps
- and in Test::Harness::Iterator.
-
-2.43_02 Thu Nov 25 00:20:36 CST 2004
- [ENHANCEMENTS]
- * Added more debug output if $Test::Harness::Debug is on.
-
- [FIXES]
- * Test::Harness now removes default paths from the paths that it
- sets in PERL5LIB. This fixes RT #5649. Thanks, Schwern.
-
- [THINGS THAT MIGHT BREAK YOUR CODE]
- * Test::Harness::Straps' constructor no longer will work as an
- object method. You can't say $strap->new any more, but that's
- OK because you never really wanted to anyway.
-
-2.43_01
- [FIXES]
- * Added workaround for local $ENV{} bug on Cygwin to
- t/prove-switches.t. See the following RT tickets for details.
-
- https://rt.cpan.org/Ticket/Display.html?id=6452
- http://rt.perl.org/rt3/Ticket/Display.html?id=30952
-
-
-2.42 Wed Apr 28 22:13:11 CDT 2004
- [ENHANCEMENTS]
- * prove -v now sets TEST_VERBOSE in case your tests rely on them.
- * prove globs the command line, since Win32's shell doesn't.
-
- [FIXES]
- * Cross-platform test fixes on t/prove-globbing.t
-
-
-2.40 Tue Dec 30 20:38:59 CST 2003
- [FIXES]
- * Test::Harness::Straps should now properly quote on VMS.
-
- [ENHANCEMENTS]
- * prove now takes a -l option to add lib/ to @INC. Now when you're
- building a module, you don't have to do a make before you run
- the prove. Thanks to David Wheeler for the idea.
-
- [INTERNALS]
- * Internal functions corestatus() and canonfailed() prepended with
- underscores, to indicate such.
-
- * Gratuitous text-only changes in Test::Harness::Iterator.
-
- * All tests now do their use_ok() in a BEGIN block. Some of the
- use_ok() calls were too much of a hassle to put into a BEGIN block,
- so I changed them to regular use calls.
-
-
-2.38 Mon Nov 24 22:36:18 CST 2003
- Released. See changes below.
-
-2.37_03 Tue Nov 18 23:51:38 CST 2003
- [ENHANCEMENTS]
- * prove -V now shows the Perl version being used.
- * Now there's a HARNESS_DEBUG flag that shows diagnostics as the
- harness runs the tests. This is different from HARNESS_VERBOSE,
- which shows test output, but not information about the harness
+Revision history for Test-Harness
+
+3.05 2007-12-09
+ - Skip unicode.t if Encode unavailable
+ - Support for .proverc files.
+ - Clarified prove documentation.
+
+3.04 2007-12-02
+ - Fixed output leakage with really_quiet set.
+ - Progress reports for tests without plans now show
+ "143/?" instead of "143/0".
+ - Made TAP::Harness::runtests support aliases for test names.
+ - Made it possible to pass command line args to test programs
+ from prove, TAP::Harness, TAP::Parser.
+ - Added --state switch to prove.
+
+3.03 2007-11-17
+ - Fixed some little bugs-waiting-to-happen inside
+ TAP::Parser::Grammar.
+ - Added parser_args callback to TAP::Harness.
+ - Made @INC propagation even more compatible with 2.64 so that
+ parrot still works *and* #30796 is fixed.
+
+3.02 2007-11-15
+ - Process I/O now unbuffered, uses sysread, plays better with
+ select. Fixes #30740.
+ - Made Test::Harness @INC propagation more compatible with 2.64.
+ Was breaking Parrot's test suite.
+ - Added HARNESS_OPTIONS (#30676)
+
+3.01 2007-11-12
+ - Fix for RHEL incpush.patch related failure.
+ - Output real time of test completion with --timer
+ - prove -b adds blib/auto to @INC
+ - made SKIP plan parsing even more liberal for pre-v13 TAP
+
+3.00 2007-11-06
+ - Non-dev release. No changes since 2.99_09.
+
+2.99_09 2007-11-05
+ - Implemented TODO-in-PLAN syntax for TAP version 12 and earlier.
+
+2.99_08 2007-11-04
+ - Tiny changes. New version pushed to get some smoke coverage.
+
+2.99_07 2007-11-01
+ - Fix for #21938: Unable to handle circular links
+ - Fix for #24926: prove -b and -l should use absolute paths
+ - Fixed prove switches. Big oops. How the hell did we miss that?
+ - Consolidated quiet, really_quiet, verbose into verbosity.
+ - Various VMS related fixes to tests
+
+2.99_06 2007-10-30
+ - Added skip_all method to TAP::Parser.
+ - Display reason for skipped tests.
+ - make test now self tests.
+
+2.99_05 2007-10-30
+ - Fix for occasional rogue -1 exit code on Windows.
+ - Fix for @INC handling under CPANPLUS.
+ - Added real time to prove --timer output
+ - Improved prove error message in case where 't' not found and
+ no tests named.
+
+2.99_04 2007-10-11
+ - Fixed bug where 'All tests successful' would not be printed if bonus
+ tests are seen.
+ - Fixed bug where 'Result: FAIL' would be printed at the end of a test
+ run if there were unexpectedly succeeding tests.
+ - Added -M, -P switches to allow arbitrary modules to be loaded
+ by prove. We haven't yet defined what they'll do once they
+ load but it's a start...
+ - Added testing under simulated non-forking platforms.
+
+2.99_03 2007-10-06
+ - Refactored all display specific code out of TAP::Harness.
+ - Relaxed strict parsing of skip plan for pre v13 TAP.
+ - Elapsed hi-res time is now displayed in integer milliseconds
+ instead of fractional seconds.
+ - prove stops running if any command-line switches are invalid.
+ - prove -v would try to print an undef.
+ - Added support for multiplexed and forked parallel tests. Use
+ prove -j 9 to run tests in parallel and prove -j 9 --fork to
+ fork. These features are experimental and currently
+ unavailable on Windows.
+ - Rationalized the management of the environment that we give to
+ test scripts (PERL5LIB, PERL5OPT, switches).
+ - Fixed handling of STDIN (we no longer close it) for test
+ scripts.
+ - Performance enhancements. Parser is now 30% - 40% faster.
+
+2.99_02 2007-09-07
+ - Ensure prove (and App::Prove) sort any recursively
+ discovered tests
+ - It is now possible to register multiple callback handlers for
+ a particular event.
+ - Added before_runtests, after_runtests callbacks to
+ TAP::Harness.
+ - Moved logic of prove program into App::Prove.
+ - Added simple machine readable summary.
+ - Performance improvement: The processing pipeline within
+ TAP::Parser is now a closure which speeds up access to the
+ various attribtes it needs.
+ - Performance improvement: Test count spinner now updates
+ exponentially less frequently as the count increases which
+ saves a lot of I/O on big tests.
+ - More improvements in test coverage from Leif.
+ - Fixes to TAP spooling - now captures YAML blocks correctly.
+ - Fix YAMLish handling of empty arrays, hashes.
+ - Renamed TAP::Harness::Compatible to Test::Harness,
+ runtests to prove.
+ - Fixes to @INC handling. We didn't always pass the correct path
+ to subprocesses.
+ - We now observe any switches in HARNESS_PERL_SWITCHES.
+ - Changes to output formatting for greater compatibility with
+ Test::Harness 2.64.
+ - Added unicode test coverage and fixed a couple of
+ unicode issues.
+ - Additions to documentation.
+ - Added support for non-forking Perls. If forking isn't
+ available we fall back to open and disable stream merging.
+ - Added support for simulating non-forking Perls to improve our
+ test coverage.
+
+========================================================================
+Version numbers below this point relate to TAP::Parser - which was the
+name of this version of Test::Harness during its development.
+========================================================================
+
+0.54
+ - Optimized I/O for common case of 'runtests -l'
+ - Croak if supplied an empty (0 lines) Perl script.
+ - Made T::P::Result::YAML return literal input YAML correctly.
+ - Merged speed-ups from speedy branch.
+
+0.53 18 August 2007
+ - Fixed a few docs nits.
+ - Added -V (--version) switch to runtests. Suggested by markjugg on
+ Perlmonks.
+ - Fixed failing t/030-grammer.t under 5.9.5. Exact cause still
+ unknown; something to do with localisation of $1 et all I think.
+ - Fixed use of three arg open in t/compat/test-harness-compat; was
+ failing on 5.6.2.
+ - Fixed runtests --exec option. T::H wasn't passing the exec option
+ to T::P.
+ - Merged Leif Eriksen's coverage enhancing changes to
+ t/080-aggregator.t, t/030-grammar.t
+ - Made various changes so that we test cleanly on 5.0.5.
+ - Many more coverage enhancements by Leif.
+ - Applied Michael Peters' patch to add an EOF callback to
+ TAP::Parser.
+ - Added --reverse option to runtests to run tests in reverse order.
+ - Made runtests exit with non-zero status if the test run had
+ problems.
+ - Stopped TAP::Parser::Iterator::Process from trampling on STDIN.
+
+0.52 14 July 2007
+ - Incorporate Schwern's investigations into TAP versions.
+ Unversioned TAP is now TAP v12. The lowest explicit version number
+ that can be specified is 13.
+ - Renumbered tests to eliminate gaps.
+ - Killed execrc. The '--exec' switch to runtests handles all of this for
+ us.
+ - Refactored T::P::Iterator into
+ T::P::Iterator::(Array|Process|Stream) so that we have a
+ process specific iterator with which to experiment with
+ STDOUT/STDERR merging.
+ - Removed vestigial exit status handling from T::P::I::Stream.
+ - Removed unused pid interface from T::P::I::Process.
+ - Fixed infinite recursion in T::P::I::Stream and added regression
+ coverage for same.
+ - Added tests for T::P::I::Process.
+ - TAP::Harness now displays the first five TAP syntax errors and
+ explains how to pass the -p flag to runtests to see them all.
+ - Added merge option to TAP::Parser::Iterator::Process,
+ TAP::Parser::Source, TAP::Parser and TAP::Harness.
+ - Added --merge option to runtests to enable STDOUT/STDERR merging.
+ This behaviour used to be the default.
+ - Made T::P::I::Process use open3 for both merged and non-merged
+ streams so that it works on Windows.
+ - Implemented Eric Wilhelm's IO::Select based multiple stream
+ handler so that STDERR is piped to us even if stream merging is
+ turned off. This tends to reduce the temporal skew between the
+ two streams so that error messages appear closer to their
+ correct location.
+ - Altered the T::P::Grammar interface so that it gets a stream
+ rather than the next line from the stream in preparation for
+ making it handle YAML diagnostics.
+ - Implemented YAML syntax. Currently YAML may only follow a
+ test result. The first line of YAML is '---' and the last
+ line is '...'.
+ - Made grammar version-aware. Different grammars may now be selected
+ depending on the TAP version being parsed.
+ - Added formatter delegate mechanism for test results.
+ - Added prototype stream based YAML(ish) parser.
+ - Added more tests for T::P::YAMLish
+ - Altered T::P::Grammar to use T::P::YAMLish
+ - Removed T::P::YAML
+ - Added raw source capture to T::P::YAMLish
+ - Added support for double quoted hash keys
+ - Added TAP::Parser::YAMLish::Writer and renamed T::P::YAMLish as
+ T::P::YAMLish::Reader.
+ - Added extra TAP::Parser::YAMLish::Writer output options
+ - Inline YAML documents must now be indented by at least one space
+ - Fixed broken dependencies in bin/prove
+ - Make library paths absolute before running tests in case tests
+ chdir before loading modules.
+ - Added libs and switches handling to T::H::Compatible. This and the
+ previous change fix [24926]
+ - Added PERLLIB to libraries stripped in _default_inc [12030]
+ - Our version of prove now handles directories containing circular
+ links correctly [21938]
+ - Set TAP_VERSION env var in Parser [11595]
+ - Added setup, teardown hooks to T::P::I::Process to facilitate the
+ setup and cleanup of the test script's environment
+ - Any additional libs added to the command line are also added to
+ PERL5LIB for the duration of a test run so that any Perl children
+ of the test script inherit the same library paths.
+ - Fixed handling of single quoted hash keys in T::P::Y::Reader
+ - Made runtests return the TAP::Parser::Aggregator
+ - Fixed t/120-harness.t has failures if TAP::Harness::Color cannot
+ load optional modules [27125] - thanks DROLSKY
+ - Fixed parsing of \# in test description
+0.51 12 March 2007
+ - 'execrc' file now allows 'regex' matches for tests.
+ - rename 'TAPx' --> 'TAP'
+ - Reimplemented the parse logic of TAP::Parser as a state machine.
+ - Removed various ad-hoc state variables from TAP::Parser and moved
+ their logic into the state machine.
+ - Removed now-unused is_first / is_last methods from Iterator and
+ simplified remaining logic to suit.
+ - Removed now-redundant t/140-varsource.t.
+ - Implemented TAP version syntax.
+ - Tidied TAP::Harness::Compatible documentation
+ - Removed redundant modules below TAP::Harness::Compatible
+ - Removed unused compatibility tests
+
+0.50_07 5 March 2007
+ - Fixed bug where we erroneously checked the test number instead of number
+ of tests run to determine if we've run more tests than we planned.
+ - Add a --directives switch to 'runtests' which only shows test results
+ with directives (such as 'TODO' or 'SKIP').
+ - Removed some dead code from TAPx::Parser.
+ - Added color support for Windows using Win32::Console.
+ - Made Color::failure_output reset colors before printing
+ the trailing newline.
+ - Corrected some issues with the 'runtests' docs and removed some
+ performance notes which no longer seem accurate.
+ - Fixed bug whereby if tests without file extensions were included then
+ the spacing of the result leaders would be off.
+ - execrc file is now a YAML file.
+ - Removed white background on the test failures. It was too garish for
+ me. Just more proof that we need better ways of overriding color
+ support.
+ - Started work on TAPx::Harness::Compatible. Right now it's mainly just
+ a direct lift of Test::Harness to make sure the tests work.
+ - Commented out use Data::Dumper::Simple in T::Harness.pm - it's not
+ a core module.
+ - Added next_raw to TAPx::Parser::Iterator which skips any fixes for
+ quirky TAP that are implemented by next. Used to support
+ TAPx::Harness::Compatible::Iterator
+ - Applied our version number to all T::H::Compatible modules
+ - Removed T::H::C::Assert. It's documented as being private to
+ Test::Harness and we're not going to need it.
+ - Refactored runtests to call aggregate_tests to expose the
+ interface we need for the compatibility layer.
+ - Make it possible to pass an end time to summary so that it needn't
+ be called immediately after the tests complete.
+ - Moved callback handling into TAPx::Base and altered TAPx::Parser
+ to use it.
+ - Made TAPx::Harness into a subclass of TAPx::Base and implemented
+ made_parser callback.
+ - Moved the dispatch of callbacks out of run and into next so that
+ they're called when TAPx::Harness iterates through the results.
+ - Implemented PERL_TEST_HARNESS_DUMP_TAP which names a directory
+ into which the raw TAP of any tests run via TAPx::Harness will
+ be written.
+ - Rewrote the TAPx::Grammar->tokenize method to return a
+ TAPx::Parser::Result object. Code is much cleaner now.
+ - Moved the official grammar from TAPx::Parser to TAPx::Parser::Grammar,
+ provided a link and updated the grammar.
+ - Fixed bug where a properly escaped '# TODO' line in a test description
+ would still be reported as a TODO test.
+ - Added patches/ExtUtils-MakeMaker-6.31.patch - a patch against EUMM
+ that makes test_harness use TAPx::Harness instead of Test::Harness
+ if PERL_EUMM_USE_TAPX is true and TAPx::Harness is installed. In
+ other words cause 'make test' for EUMM based models to use
+ TAPx::Harness.
+ - Added support for timer option to TAPx::Harness which causes the
+ elapsed time for each test to be displayed.
+ - Setup tapx-dev@hexten.net mailing list.
+ - Fixed accumulating @$exec bug in TAPx::Harness.
+ - Made runtests pass '--exec' option as an array.
+ - (#24679) TAPx::Harness now reports failure for tests that die
+ after completing all subtests.
+ - Added in_todo attribute on TAPx::Parser which is true while the
+ most recently seen test was a TODO.
+ - (#24728) TAPx::Harness now supresses diagnostics from failed
+ TODOs. Not sure if the semantics of this are correct yet.
+
+0.50_06 18 January 2007
+ - Fixed doc typo in examples/README [rt.cpan.org #24409]
+ - Colored test output is now the default for 'runtests' unless
+ you're running under windows or -t STDOUT is false.
+ [rt.cpan.org #24310]
+ - Removed the .t extension from t/source_tests/*.t since those are
+ 'test tests' which caused false negatives when running recursive
+ tests. [Adrian Howard]
+ - Somewhere along the way, the exit status started working again.
+ Go figure.
+ - Factored color output so that disabling it under Windows is
+ cleaner.
+ - Added explicit switch to :crlf layer after open3 under Windows.
+ open3 defaults to raw mode resulting in spurious \r characters input
+ parsed input.
+ - Made Iterator do an explicit wait for subprocess termination.
+ Needed to get process status correctly on Windows.
+ - Fixed bug which didn't allow t/010-regression.t to be run directly
+ via Perl unless you specified Perl's full path.
+ - Removed SIG{CHLD} handler (which we shouldn't need I think because
+ we explicitly waitpid) and made binmode ':crlf' conditional on
+ IS_WIN32. On Mac OS these two things combined to expose a problem
+ which meant that output from test scripts was sometimes lost.
+ - Made t/110-source.t use File::Spec->catfile to build path to
+ test script.
+ - Made Iterator::FH init is_first, is_last to 0 rather than undef
+ for consistency with array iterator.
+ - Added t/120-varsource.t to test is_first and is_last semantics
+ over files with small numbers of lines.
+ - Added check for valid callback keys.
+ - Added t/130-results.t for Result classes.
+
+0.50_05 15 January 2007
+ - Removed debugging code accidentally left in bin/runtests.
+ - Removed 'local $/ = ...' from the iterator. Hopefully that will fix the
+ line ending bug, but I don't know about the wstat problem.
+
+0.50_04 14 January 2007
+ - BACKWARDS IMCOMPATIBLE: Renamed all '::Results' classes to '::Result'
+ because they represent a single result.
+ - Fixed bug where piping would break verbose output.
+ - IPC::Open3::open3 now takes a @command list rather than a $command
+ string. This should make it work under Windows.
+ - Added 'stdout_sterr' sample test back to regression tests. IPC::Open3
+ appears to make it work.
+ - Bug fix: don't print 'All tests successful' if no tests are run.
+ - Refactored 'runtests' to make it a bit easier to follow.
+ - Bug fix: Junk and comments now allowed before a leading plan.
+ - HARNESS_ACTIVE and HARNESS_VERSION environment variables now set.
+ - Renamed 'problems' in TAPx::Parser and TAPx::Aggregator to
+ 'has_problems'.
+
+0.50_03 08 January 2007
+
+ - Fixed bug where '-q' or '-Q' with colored tests weren't suppressing all
+ information.
+ - Fixed an annoying MANIFEST nit.
+ - Made '-h' for runtests now report help. Using a new harness requires
+ the full --harness switch.
+ - Added 'problems' method to TAPx::Parser and TAPx::Parser::Aggregator.
+ - Deprecatd 'todo_failed' in favor of 'todo_passed'
+ - Add -I switch to runtests.
+ - Fixed runtests doc nit (smylers)
+ - Removed TAPx::Parser::Builder.
+ - A few more POD nits taken care of.
+ - Completely removed all traces of C<--merge> as IPC::Open3 seems to be
+ working.
+ - Moved the tprove* examples to examples/bin in hopes of them no longer
+ showing up in CPAN's docs.
+ - Made the 'unexpectedly succeeded' message clearer (Adam Kennedy)
+
+0.50_02 06 January 2007
+ - Added some files I left out of the manifest (reported by Florian
+ Ragwitz).
+ - Added strict to Makefile.PL and changed @PROGRAM to @program (reported
+ Florian Ragwitz).
+
+0.50_01 06 January 2007
+ - Added a new example which shows to how test Perl, Ruby, and URLs all at
+ the same time using 'execrc' files.
+ - Fixed the diagnostic format mangling bug.
+ - We no longer override Test::Builder to merge streams. Instead, we go
+ ahead and use IPC::Open3. It remains to be seen whether or not this is
+ a good idea.
+ - Fixed vms nit: for failing tests, vms often has the 'not' on a line by
itself.
- * Added _command_line() to the Strap API.
-
- [FIXES]
- * Bad interaction with Module::Build: The strap was only checking
- $ENV{HARNESS_PERL_SWITCHES} for definedness, but not emptiness.
- It now also strips any leading or trailing whitesapce from the
- switches.
- * Test::Harness and prove only quote those parms that actually need
- to be quoted: Have some whitespace and aren't already quoted.
-
-2.36 Fri Nov 14 09:24:44 CST 2003
- [FIXES]
- * t/prove-includes.t properly ignores PROVE_SWITCHES that you may
- already have set.
-
-2.35_02 Thu Nov 13 09:57:36 CST 2003
- [ENHANCEMENTS]
- * prove's --blib now works just like the blib pragma.
-
-2.35_01 Wed Nov 12 23:08:45 CST 2003
- [FIXES]
- * Fixed taint-handling and path preservation under MacOS. Thanks to
- Schwern for the patch and the tests.
-
- * Preserves case of -t or -T in the shebang line of the test.
-
- [ENHANCEMENTS]
- * Added -t to prove analogous to Perl's -t. Removed the --taint
- switch.
-
- * prove can take default options from the PROVE_SWITCHES variable.
-
- * Added HARNESS_PERL to allow you to specify the Perl interpreter
- to run the tests as.
-
- * prove's --perl switch sets the HARNESS_PERL on the fly for you.
-
- * Quotes the switches and filename in the subprogram. This helps
- with filenames with spaces that are subject to shell mangling.
-
-
-2.34 Sat Nov 8 22:09:15 CST 2003
- [FIXES]
- * Allowed prove to run on Perl versions < 5.6.0.
-
- [ENHANCEMENTS]
- * Command-line switches to prove may now be stacked.
- * Added check for proper Pod::Usage version.
- * "make clean" does a better job of cleaning up after itself.
-
-
-2.32 Fri Nov 7 09:41:21 CST 2003
- Test::Harness now includes a powerful development tool to help
- programmers work with automated tests. The prove utility runs
- test files against the harness, like a "make test", but with many
- advantages:
-
- * prove is designed as a development tool
- Perl users typically run the test harness through a makefile via
- "make test". That's fine for module distributions, but it's
- suboptimal for a test/code/debug development cycle.
-
- * prove is granular
- prove lets your run against only the files you want to check.
- Running "prove t/live/ t/master.t" checks every *.t in t/live, plus
- t/master.t.
-
- * prove has an easy verbose mode
- To get full test program output from "make test", you must set
- "HARNESS_VERBOSE" in the environment. prove has a "-v" option.
-
- * prove can run under taint mode
- prove's "-T" runs your tests under "perl -T".
-
- * prove can shuffle tests
- You can use prove's "--shuffle" option to try to excite problems
- that don't show up when tests are run in the same order every time.
-
- * Not everything is a module
- More and more users are using Perl's testing tools outside the
- context of a module distribution, and may not even use a makefile at
- all.
-
- Prove requires Pod::Usage, which is standard after Perl 5.004.
-
- I'm very excited about prove, and hope that developers will begin
- adopting it to their coding cycles. I welcome your comments at
- andy@petdance.com.
-
- There are also some minor bug fixes in Test::Harness itself, listed
- below in the 2.31_* notes.
-
-
-2.31_05 Thu Nov 6 14:56:22 CST 2003
- [FIXES]
- - If a MacPerl script had a shebang with -T, the -T wouldn't get
- passed as a switch.
- - Removed the -T on three *.t files, which didn't need them, and
- which were causing problems.
- - Conditionally installs bin/prove, depending on whether Pod::Usage
- is available, which prove needs.
- - Removed old leftover code from Makefile.PL.
-
-2.31_04 Mon Nov 3 23:36:06 CST 2003
- Minor tweaks here and there, almost ready to release.
-
-2.31_03 Mon Nov 3 08:50:36 CST 2003
- [FEATURES]
- - prove is almost feature-complete. Removed the handling of
- --exclude for excluding certain tests. It may go back in the
- future.
- - prove -d is now debug. Dry is prove -D.
-
-2.31_02 Fri Oct 31 23:46:03 CST 2003
- [FEATURES]
- - Added many more switches to prove: -d for dry run, and -b for
- blib.
-
- [FIXES]
- - T:H:Straps now recognizes MSWin32 in $^0.
- - RT#3811: Could do regex matching on garbage in _is_test().
- Fixed by Yves Orton
- - RT#3827: Strips backslashes from and normalizes @INC entries
- for Win32. Fixed by Yves Orton.
-
- [INTERNALS]
- - Added $self->{_is_macos} to the T:H:Strap object.
- - t/test-harness.t sorts its test results, rather than relying on
- internal key order.
-
-2.31_01
- [FEATURES]
- - Added "prove" script to run a test or set of tests through the
- harness. Thanks to Curtis Poe for the foundation.
-
- [DOCUMENTATION]
- - Fixed POD problem in Test::Harness::Assert
-
-2.30 Thu Aug 14 20:04:00 CDT 2003
- No functional changes in this version. It's only to make some doc
- tweaks, and bump up the version number in T:H:Straps.
-
- [DOCUMENTATION]
- - Changed Schwern to Andy as the maintainer.
- - Incorporated the TODO file into Harness.pm proper.
- - Cleaned up formatting in Test::Harness::Straps.
-
-2.29 Wed Jul 17 14:08:00 CDT 2003
- - Released as 2.29.
-
-2.28_91 Sun Jul 13 00:10:00 CDT 2003
- [ENHANCEMENTS]
- - Added support for HARNESS_OK_SLOW. This will make a significant
- speedup for slower connections.
- - Folded in some changes from bleadperl that spiff up the
- failure reports.
-
- [INTERNALS]
- - Added some isa_ok() checks to the tests.
- - All Test::Harness* modules are used by use_ok()
- - Fixed the prototype for the canonfailed() function, not that
- it matters since it's never called without parens.
-
-2.28_90 Sat Jul 05 20:21:00 CDT 2003
- [ENHANCEMENTS]
- - Now, when you run a test harnessed, the numbers don't fly by one
- at a time, one update per second. This significantly speeds
- up the run time for running thousands of tests. *COUGH*
- Regexp::Common *COUGH*
-
-2.28 Thu Apr 24 14:39:00 CDT 2003
- - No functional changes.
-
-2.27_05 Mon Apr 21 15:55:00 CDT 2003
- - No functional changes.
- - Fixed circular depency in the test suite. Thanks, Rob Brown.
-
-2.27_04 Sat Apr 12 21:42:00 CDT 2003
- - Added test for $Test::Harness::Switches patch below.
-
-2.27_03 Thu Apr 03 10:47:00 CDT 2003
- - Fixed straps not respecting $Test::Harness::Switches. Thanks
- to Miyagawa for the patch.
- - Added t/pod.t to test POD validity.
-
-2.27_02 Mon Mar 24 13:17:00 CDT 2003
-2.27_01 Sun Mar 23 19:46:00 CDT 2003
- - Handed over to Andy Lester for further maintenance.
- - Fixed when the path to perl contains spaces on Windows
- * Stas Bekman noticed that tests with no output at all were
- interpreted as passing
- - MacPerl test tweak for busted exit codes (bleadperl 17345)
- - Abigail and Nick Clark both hit the 100000 "huge test that will
- suck up all your memory" limit with legit tests. Made the check
- smarter to allow large, planned tests to work.
- - Partial fix of stats display when a test fails only because there's
- too many tests.
- - Made wait.ph and WCOREDUMP anti-vommit protection more robust in
- cases where wait.ph loads but WCOREDUMP() pukes when run.
- - Added a LICENSE.
- - Ilya noticed the per test skip reason was accumlating between tests.
-
-2.26 Wed Jun 19 16:58:02 EDT 2002
- - Workaround for MacPerl's lack of a working putenv. It will never
- see the PERL5LIB environment variable (perl@16942).
-
-2.25 Sun Jun 16 03:00:33 EDT 2002
- - $Strap is now a global to allow Test::Harness::Straps
- experimentation.
- - Little spelling nit in a diagnostic.
- - Chris Richmond noted that the runtests() docs were wrong. It will
- die, not return false, when any tests fail. This is silly, but
- historically necessary for 'make test'. Docs corrected.
- - MacPerl test fixes from Pudge. (mutation of bleadperl@16989)
- - Undef warning introduced in 2.24 on skipped tests with no reasons
- fixed.
- * Test::Harness now depends on File::Spec
-
-2.24 Wed May 29 19:02:18 EDT 2002
- * Nikola Knezevic found a bug when tests are completely skipped
- but no reason is given it was considered a failure.
- * Made Test::Harness::Straps->analyze_file & Test::Harness a bit
- more graceful when the test doesn't exist.
-
-2.23 Wed May 22 12:59:47 EDT 2002
- - reason for all skip wasn't being displayed. Broken in 2.20.
- - Changed the wait status tests to conform with POSIX standards.
- - Quieted some SYSTEM$ABORT noise leaking out from dying test tests
- on VMS.
-
-2.22 Fri May 17 19:01:35 EDT 2002
- - Fixed parsing of #!/usr/bin/perl-current to not see a -t.
- (RT #574)
- - Fixed exit codes on MPE/iX
-
-2.21 Mon May 6 00:43:22 EDT 2002
- - removed a bunch of dead code left over after 2.20's gutting.
- - The fix for the $^X "bug" added in 2.02 has been removed. It
- caused more trouble than the old bug (I'd never seen a problem
- before anyway)
- - 2.20 broke $verbose
-
-2.20 Sat May 4 22:31:20 EDT 2002
- * An almost complete conversion of the Test::Harness test parsing
- to use Test::Harness::Straps.
-
-2.04 Tue Apr 30 00:54:49 EDT 2002
- * Changing the output format of skips
- - Taking into account VMS's special exit codes in the tests.
-
-2.03 Thu Apr 25 01:01:34 EDT 2002
- * $^X fix made safer.
- - Noise from loading wait.ph to analyze core files supressed
- - MJD found a situation where a test could run Test::Harness
- out of memory. Protecting against that specific case.
- - Made the 1..M docs a bit clearer.
- - Fixed TODO tests so Test::Harness does not display a NOK for
+ - Fixed bugs where unplanned tests were not reporting as a failure (test
+ number greater than tests planned).
+ - TAPx::Parser constructor can now take an 'exec' option to tell it what
+ to execute to create the stream (huge performance boost).
+ - Added TAPx::Parser::Source. This allows us to run tests in just about
+ any programming language.
+ - Renamed the filename() method to source() in TAPx::Parser::Source::Perl.
+ - We now cache the @INC values found for TAPx::Parser::Source::Perl.
+ - Added two test harnesses, TAPx::Harness and TAPx::Harness::Color.
+ - Removed references to manual stream construction from TAPx::Parser
+ documentation. Users should not (usually) need to worry about streams.
+ - Added bin/runtests utility. This is very similar to 'prove'.
+ - Renumbered tests to make it easier to add new ones.
+ - Corrected some minor documentation nits.
+ - Makefile.PL is no longer auto-generated (it's built by hand).
+ - Fixed regression test bug where driving tests through the harness I'm
+ testing caused things to break.
+ - BUG: exit() values are now broken. I don't know how to capture them
+ with IPC::Open3. However, since no one appears to be using them, this
+ might not be an issue.
+
+0.41 12 December 2006
+ - Fixed (?) 10-regression.t test which failed on Windows. Removed the
+ segfault test as it has no meaning on Windows. Reported by PSINNOTT
+ <link@redbrick.dcu.ie> and fix recommended by Schwern based on his
+ Test::Harness experience.
+ http://rt.cpan.org/Ticket/Display.html?id=21624
+
+0.40 05 December 2006
+ - Removed TAPx::Parser::Streamed and folded its functionality into
+ TAPx::Parser.
+ - Fixed bug where sometimes is_good_plan() would return a false positive
+ (exposed by refactoring).
+ - A number of tiny performance enhancements.
+
+0.33 22 September 2006
+ - OK, I'm getting ticked off by some of the comments on Perl-QA so I
+ rushed this out the door and broke it :( I'm backing out one test and
+ slowing down a bit.
+
+0.32 22 September 2006
+ - Applied patch from Schwern which fixed the Builder package name (TAPx::
+ instead of TAPX:: -- stupid case-insensitive package names!).
+ [rt.cpan.org #21605]
+
+0.31 21 September 2006
+ - Fixed bug where Carp::croak without parens could cause Perl to fail to
+ compile on some platforms. [Andreas J. Koenig]
+ - Eliminated the non-portable redirect of STDERR to STDOUT (2>&1) and
+ fixed the synchronization issue. This involves overridding
+ Test::Builder::failure_output() in a very sneaky way. I may have to
+ back this out.
+ - Renamed boolean methods to begin with 'is_'. The methods they replace
+ are documented, deprecated, and will not be removed prior to version
+ 1.00.
+
+0.30 17 September 2006
+ - Fixed bug where no output would still claim to have a good plan.
+ - Fixed bug where no output would cause parser to die.
+ - Fixed bug where failing to specify a plan would be two parse errors
+ instead of one.
+ - Fixed bug where a correct plan count in an incorrect place would still
+ report as a 'good_plan'.
+ - Fixed bug where comments could accidently be misparsed as directives.
+ - Eliminated testing of internal structure of result objects. The other
+ tests cover this.
+ - Allow hash marks in descriptions. This was causing a problem because
+ many test suites (Regexp::Common and Perl core) allowed them to exist.
+ - Added support for SKIP directives in plans.
+ - Did some work simplifying &TAPx::Parser::_initialize. It's not great,
+ but it's better than it was.
+ - TODO tests now always pass, regardless of actual_passed status.
+ - Removed 'use warnings' and now use -w
+ - 'switches' may now be passed to the TAPx::Parser constructor.
+ - Added 'exit' status.
+ - Added 'wait' status.
+ - Eliminated 'use base'. This is part of the plan to make TAPx::Parser
+ compatible with older versions of Perl.
+ - Added 'source' key to the TAPx::Parser constructor. Making new parsers
+ is now much easier.
+ - Renamed iterator first() and last() methods to is_first() and is_last().
+ Credit: Aristotle.
+ - Planned tests != tests run is now a parse error. It was really stupid
+ of me not to do that in the first place.
+ - Added massive regression test suite in t/100-regression.t
+ - Updated the grammar to show that comments are allowed.
+ - Comments are now permitted after an ending plan.
+
+0.22 13 September 2006
+ - Removed buggy support for multi-line chunks from streams. If your
+ streams or iterators return anything but single lines, this is a bug.
+ - Fixed bug whereby blank lines in TAP would confuse the parser. Reported
+ by Torsten Schoenfeld.
+ - Added first() and last() methods to the iterator.
+ - TAPx::Parser::Source::Perl now has a 'switches' method which allows
+ switches to be passed to the perl executable running the test file.
+ This allows tprove to accept a '-l' argument to force lib/ to be
+ included in Perl's @INC.
+
+0.21 8 September 2006
+ - Included experimental GTK interface written by Torsten Schoenfeld.
+ - Fixed bad docs in examples/tprove_color
+ - Applied patch from Shlomi Fish fixing bug where runs from one stream
+ could leak into another when bailing out. [rt.cpan.org #21379]
+ - Fixed some typos in the POD.
+ - Corrected the grammar to allow for a plan of "1..0" (infinite stream).
+ - Started to add proper acknowledgements.
+
+0.20 2 September 2006
+ - Fixed bug reported by GEOFFR. When no tap output was found, an
+ "Unitialized value" warning occurred. [rt.cpan.org #21205]
+ - Updated tprove to now report a test failure when no tap output found.
+ - Removed examples/tprove_color2 as tprove_color now works.
+ - Vastly improved callback system and updated the docs for how to use
them.
- - Test::Harness::Straps->analyze_file() docs were not clear as to
- its effects
-
-2.02 Thu Mar 14 18:06:04 EST 2002
- * Ken Williams fixed the long standing $^X bug.
- * Added HARNESS_VERBOSE
- * Fixed a bug where Test::Harness::Straps was considering a test that
- is ok but died as passing.
- - Added the exit and wait codes of the test to the
- analyze_file() results.
-
-2.01 Thu Dec 27 18:54:36 EST 2001
- * Added 'passing' to the results to tell you if the test passed
- * Added Test::Harness::Straps example (examples/mini_harness.plx)
- * Header-at-end tests were being interpreted as failing sometimes
- - The 'skip_all' results from analyze* was not being set
- - analyze_fh() and analyze_file() now work more efficiently, reading
- line-by-line instead of slurping as before.
-
-2.00 Sun Dec 23 19:13:57 EST 2001
- - Fixed a warning on VMS.
- - Removed a little unnecessary code from analyze_file()
- - Made sure filehandles are getting closed
- - analyze() now considers "not \nok" to be a failure (VMSism)
- but Test::Harness still doesn't.
-
-2.00_05 Mon Dec 17 22:08:02 EST 2001
- * Wasn't filtering @INC properly when a test is run with -T, caused the
- command line to be too long on VMS. VMS should be 100% now.
- - Little bug in the skip 'various reasons' logic.
- - Minor POD nit in 5.004_04
- - Little speling mistak
-
-2.00_04 Sun Dec 16 00:33:32 EST 2001
- * Major Test::Harness::Straps doc bug.
-
-2.00_03 Sat Dec 15 23:52:17 EST 2001
- * First release candidate
- * 'summary' is now 'details'
- * Test #1 is now element 0 on the details array. It works out better
- that way.
- * analyze_file() is more portable, but no longer taint clean
- * analyze_file() properly preserves @INC and handles -T switches
- - minor mistake in the test header line parsing
-
-1.26 Mon Nov 12 15:44:01 EST 2001
- * An excuse to upload a new version to CPAN to get Test::Harness
- back on the index.
-
-2.00_00 Sat Sep 29 00:12:03 EDT 2001
- * Partial gutting of the internals
- * Added Test::Harness::Straps
-
-1.25 Tue Aug 7 08:51:09 EDT 2001
- * Fixed a bug with tests failing if they're all skipped
- reported by Stas Bekman.
- - Fixed a very minor warning in 5.004_04
- - Fixed displaying filenames not from @ARGV
- - Merging with bleadperl
- - minor fixes to the filename in the report
- - '[no reason given]' skip reason
-
-1.24 Tue Aug 7 08:51:09 EDT 2001
- - Added internal information about number of todo tests
-
-1.23 Tue Jul 31 15:06:47 EDT 2001
- - Merged in Ilya's "various reasons" patch
- * Fixed "not ok 23 - some name # TODO" style tests
-
-1.22 Mon Jun 25 02:00:02 EDT 2001
- * Fixed bug with failing tests using header at end.
- - Documented how Test::Harness deals with garbage input
- - Turned on test counter mismatch warning
-
-1.21 Wed May 23 19:22:53 BST 2001
- * No longer considered unstable. Merging back with the perl core.
- - Fixed minor nit about the report summary
- - Added docs on the meaning of the failure report
- - Minor POD nits fixed mirroring perl change 9176
- - TODO and SEE ALSO expanded
-
-1.20 Wed Mar 14 23:09:20 GMT 2001 by Michael G Schwern *UNSTABLE*
- * Fixed and tested with 5.004!
- - Added EXAMPLE docs
- - Added TODO docs
- - Now uneffected by -l, $\ or $,
-
-1.19 Sat Mar 10 00:43:29 GMT 2001 by Michael G Schwern *UNSTABLE*
- - More internal reworking
- * Removed use of experimental /(?>...)/ feature for backwards compat
- * Removed use of open(my $fh, $file) for backwards compatibility
- * Removed use of Tie::StdHandle in tests for backwards compat
- * Added dire warning that this is unstable.
- - Added some tests from the old CPAN release
-
-1.18 Mon Mar 5 17:35:11 GMT 2001 by Michael G Schwern
- * Under new management!
- * Test::Harness is now being concurrently shipped on CPAN as well
- as in the core.
- - Switched "our" for "use vars" and moved the minimum version back
- to 5.004. This may be optimistic.
-
-
-*** Missing version history to be extracted from Perl changes ***
-
-
-1.07 Fri Feb 23 1996 by Andreas Koenig
- - Gisle sent me a documentation patch that showed me, that the
- unless(/^#/) is unnessessary. Applied the patch and deleted the block
- checking for "comment" lines. -- All lines are comment lines that do
- not match /^1\.\.([0-9]+)/ or /^(not\s+)?ok\b/.
- - Ilyaz request to print "ok (empty test case)" whenever we say 1..0
- implemented.
- - Harness now doesn't abort anymore if we received confused test output,
- just warns instead.
-
-1.05 Wed Jan 31 1996 by Andreas Koenig
- - More updates on docu and introduced the liberality that the script
- output may omit the test numbers.
-
-1.03 Mon January 28 1996 by Andreas Koenig
- - Added the statistics for subtests. Updated the documentation.
-
-1.02 by Andreas Koenig
- - This version reports a list of the tests that failed accompanied by
- some trivial statistics. The older (unnumbered) version stopped
- processing after the first failed test.
- - Additionally it reports the exit status if there is one.
-
-
+ - Changed TAPx::Parser::Source::Perl to use Symbol::gensym() instead of a
+ hard-to-guess filehandle name.
+
+0.12 30 July 2006
+ - Added a test colorization script
+ - Callback support added.
+ - Added TAPx::Parser::Source::Perl.
+ - Added TAPx::Parser::Aggregator.
+ - Added version numbers to all classes.
+ - Added 'todo_failed' test result and parser.
+ - 00-load.t now loads all classes instead of having individual tests load
+ their supporting classes.
+ - Changed $parser->results to $parser->next
+
+0.11 25 July, 2006
+ - Renamed is_skip and is_todo to has_skip and has_todo. Much less
+ confusing since a result responding true to those also responded true to
+ is_test.
+ - Added simplistic bin/tprove to run tests. Much harder than I thought
+ and much code stolen from Test::Harness.
+ - Modified stolen iterator to fix a bug with stream handling when extra
+ newlines were encountered.
+ - Added TAPx::Parser::Iterator (stolen from Test::Harness::Iterator)
+ - Normalized internal structure of result objects.
+ - All tokens now have a 'type' key. This greatly simplifies internals.
+ - Copied much result POD info into the main docs.
+ - Corrected the bug report URLs.
+ - Minor updates to the grammar listed in the POD.
+
+0.10 23 July, 2006
+ - Oh my Larry, we gots docs!
+ - _parse and _tap are now private methods.
+ - Stream support has been added.
+ - Moved the grammar into its own class.
+ - Pulled remaining parser functionality out of lexer.
+ - Added type() method to Results().
+ - Parse errors no longer croak(). Instead, they are available through the
+ parse_errors() method.
+ - Added good_plan() method.
+ - tests_planned != tests_run is no longer a parse error.
+ - Renamed test_count() to tests_run().
+ - Renamed num_tests() to tests_planned().
+
+0.03 17 July, 2006
+ - 'Bail out!' is now handled.
+ - The parser is now data driven, thus skipping a huge if/else chain
+ - We now track all TODOs, SKIPs, passes and fails by test number.
+ - Removed all non-core modules.
+ - Store original line for each TAP line. Available through
+ $result->raw().
+ - Renamed test is_ok() to passed() and added actual_passed(). The former
+ method takes into account TODO tests and the latter returns the actual
+ pass/fail status.
+ - Fixed a bug where SKIP tests would not be identified correctly.
+
+0.02 8 July, 2006
+ - Moved some lexer responsibility to the parser. This will allow us to
+ eventually parse streams.
+ - Properly track passed/failed tests, even accounting for TODO.
+ - Added support for comments and unknown lines.
+ - Allow explicit and inferred test numbers to be mixed.
+ - Allow escaped hashes in the test description.
+ - Renamed to TAPx::Parser. Will probably rename it again.
+
+0.01 Date/time
+ - First version, unreleased on an unsuspecting world.
+ - No, you'll never know when ...
+++ /dev/null
-package Test::Harness::Iterator;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = 0.02;
-
-=head1 NAME
-
-Test::Harness::Iterator - Internal Test::Harness Iterator
-
-=head1 SYNOPSIS
-
- use Test::Harness::Iterator;
- my $it = Test::Harness::Iterator->new(\*TEST);
- my $it = Test::Harness::Iterator->new(\@array);
-
- my $line = $it->next;
-
-=head1 DESCRIPTION
-
-B<FOR INTERNAL USE ONLY!>
-
-This is a simple iterator wrapper for arrays and filehandles.
-
-=head2 new()
-
-Create an iterator.
-
-=head2 next()
-
-Iterate through it, of course.
-
-=cut
-
-sub new {
- my($proto, $thing) = @_;
-
- my $self = {};
- if( ref $thing eq 'GLOB' ) {
- bless $self, 'Test::Harness::Iterator::FH';
- $self->{fh} = $thing;
- }
- elsif( ref $thing eq 'ARRAY' ) {
- bless $self, 'Test::Harness::Iterator::ARRAY';
- $self->{idx} = 0;
- $self->{array} = $thing;
- }
- else {
- warn "Can't iterate with a ", ref $thing;
- }
-
- return $self;
-}
-
-package Test::Harness::Iterator::FH;
-sub next {
- my $fh = $_[0]->{fh};
-
- # readline() doesn't work so good on 5.5.4.
- return scalar <$fh>;
-}
-
-
-package Test::Harness::Iterator::ARRAY;
-sub next {
- my $self = shift;
- return $self->{array}->[$self->{idx}++];
-}
-
-"Steve Peters, Master Of True Value Finding, was here.";
https://perl5.git.perl.org / perl5.git / commitdiff