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.";
+++ /dev/null
-# -*- Mode: cperl; cperl-indent-level: 4 -*-
-package Test::Harness::Point;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.01';
-
-=head1 NAME
-
-Test::Harness::Point - object for tracking a single test point
-
-=head1 SYNOPSIS
-
-One Test::Harness::Point object represents a single test point.
-
-=head1 CONSTRUCTION
-
-=head2 new()
-
- my $point = new Test::Harness::Point;
-
-Create a test point object.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
-
- return $self;
-}
-
-=head1 from_test_line( $line )
-
-Constructor from a TAP test line, or empty return if the test line
-is not a test line.
-
-=cut
-
-sub from_test_line {
- my $class = shift;
- my $line = shift or return;
-
- # We pulverize the line down into pieces in three parts.
- my ($not, $number, $extra) = ($line =~ /^(not )?ok\b(?:\s+(\d+))?\s*(.*)/) or return;
-
- my $point = $class->new;
- $point->set_number( $number );
- $point->set_ok( !$not );
-
- if ( $extra ) {
- my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
- $description =~ s/^- //; # Test::More puts it in there
- $point->set_description( $description );
- if ( $directive ) {
- $point->set_directive( $directive );
- }
- } # if $extra
-
- return $point;
-} # from_test_line()
-
-=head1 ACCESSORS
-
-Each of the following fields has a getter and setter method.
-
-=over 4
-
-=item * ok
-
-=item * number
-
-=cut
-
-sub ok { my $self = shift; $self->{ok} }
-sub set_ok {
- my $self = shift;
- my $ok = shift;
- $self->{ok} = $ok ? 1 : 0;
-}
-sub pass {
- my $self = shift;
-
- return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
-}
-
-sub number { my $self = shift; $self->{number} }
-sub set_number { my $self = shift; $self->{number} = shift }
-
-sub description { my $self = shift; $self->{description} }
-sub set_description {
- my $self = shift;
- $self->{description} = shift;
- $self->{name} = $self->{description}; # history
-}
-
-sub directive { my $self = shift; $self->{directive} }
-sub set_directive {
- my $self = shift;
- my $directive = shift;
-
- $directive =~ s/^\s+//;
- $directive =~ s/\s+$//;
- $self->{directive} = $directive;
-
- my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
- $self->set_directive_type( $type );
- $reason = "" unless defined $reason;
- $self->{directive_reason} = $reason;
-}
-sub set_directive_type {
- my $self = shift;
- $self->{directive_type} = lc shift;
- $self->{type} = $self->{directive_type}; # History
-}
-sub set_directive_reason {
- my $self = shift;
- $self->{directive_reason} = shift;
-}
-sub directive_type { my $self = shift; $self->{directive_type} }
-sub type { my $self = shift; $self->{directive_type} }
-sub directive_reason{ my $self = shift; $self->{directive_reason} }
-sub reason { my $self = shift; $self->{directive_reason} }
-sub is_todo {
- my $self = shift;
- my $type = $self->directive_type;
- return $type && ( $type eq 'todo' );
-}
-sub is_skip {
- my $self = shift;
- my $type = $self->directive_type;
- return $type && ( $type eq 'skip' );
-}
-
-sub diagnostics {
- my $self = shift;
- return @{$self->{diagnostics}} if wantarray;
- return join( "\n", @{$self->{diagnostics}} );
-}
-sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ }
-
-
-1;
+++ /dev/null
-# -*- Mode: cperl; cperl-indent-level: 4 -*-
-package Test::Harness::Results;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.01';
-
-=head1 NAME
-
-Test::Harness::Results - object for tracking results from a single test file
-
-=head1 SYNOPSIS
-
-One Test::Harness::Results object represents the results from one
-test file getting analyzed.
-
-=head1 CONSTRUCTION
-
-=head2 new()
-
- my $results = new Test::Harness::Results;
-
-Create a test point object. Typically, however, you'll not create
-one yourself, but access a Results object returned to you by
-Test::Harness::Results.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
-
- return $self;
-}
-
-=head1 ACCESSORS
-
-The following data points are defined:
-
- passing true if the whole test is considered a pass
- (or skipped), false if its a failure
-
- exit the exit code of the test run, if from a file
- wait the wait code of the test run, if from a file
-
- max total tests which should have been run
- seen total tests actually seen
- skip_all if the whole test was skipped, this will
- contain the reason.
-
- ok number of tests which passed
- (including todo and skips)
-
- todo number of todo tests seen
- bonus number of todo tests which
- unexpectedly passed
-
- skip number of tests skipped
-
-So a successful test should have max == seen == ok.
-
-
-There is one final item, the details.
-
- details an array ref reporting the result of
- each test looks like this:
-
- $results{details}[$test_num - 1] =
- { ok => is the test considered ok?
- actual_ok => did it literally say 'ok'?
- name => name of the test (if any)
- diagnostics => test diagnostics (if any)
- type => 'skip' or 'todo' (if any)
- reason => reason for the above (if any)
- };
-
-Element 0 of the details is test #1. I tried it with element 1 being
-#1 and 0 being empty, this is less awkward.
-
-
-Each of the following fields has a getter and setter method.
-
-=over 4
-
-=item * wait
-
-=item * exit
-
-=cut
-
-sub set_wait { my $self = shift; $self->{wait} = shift }
-sub wait {
- my $self = shift;
- return $self->{wait} || 0;
-}
-
-sub set_skip_all { my $self = shift; $self->{skip_all} = shift }
-sub skip_all {
- my $self = shift;
- return $self->{skip_all};
-}
-
-sub inc_max { my $self = shift; $self->{max} += (@_ ? shift : 1) }
-sub max {
- my $self = shift;
- return $self->{max} || 0;
-}
-
-sub set_passing { my $self = shift; $self->{passing} = shift }
-sub passing {
- my $self = shift;
- return $self->{passing} || 0;
-}
-
-sub inc_ok { my $self = shift; $self->{ok} += (@_ ? shift : 1) }
-sub ok {
- my $self = shift;
- return $self->{ok} || 0;
-}
-
-sub set_exit {
- my $self = shift;
- if ($^O eq 'VMS') {
- eval {
- use vmsish q(status);
- $self->{exit} = shift; # must be in same scope as pragma
- }
- }
- else {
- $self->{exit} = shift;
- }
-}
-sub exit {
- my $self = shift;
- return $self->{exit} || 0;
-}
-
-sub inc_bonus { my $self = shift; $self->{bonus}++ }
-sub bonus {
- my $self = shift;
- return $self->{bonus} || 0;
-}
-
-sub set_skip_reason { my $self = shift; $self->{skip_reason} = shift }
-sub skip_reason {
- my $self = shift;
- return $self->{skip_reason} || 0;
-}
-
-sub inc_skip { my $self = shift; $self->{skip}++ }
-sub skip {
- my $self = shift;
- return $self->{skip} || 0;
-}
-
-sub inc_todo { my $self = shift; $self->{todo}++ }
-sub todo {
- my $self = shift;
- return $self->{todo} || 0;
-}
-
-sub inc_seen { my $self = shift; $self->{seen}++ }
-sub seen {
- my $self = shift;
- return $self->{seen} || 0;
-}
-
-sub set_details {
- my $self = shift;
- my $index = shift;
- my $details = shift;
-
- my $array = ($self->{details} ||= []);
- $array->[$index-1] = $details;
-}
-
-sub details {
- my $self = shift;
- return $self->{details} || [];
-}
-
-1;
+++ /dev/null
-# -*- Mode: cperl; cperl-indent-level: 4 -*-
-package Test::Harness::Straps;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.26_01';
-
-use Config;
-use Test::Harness::Assert;
-use Test::Harness::Iterator;
-use Test::Harness::Point;
-use Test::Harness::Results;
-
-# Flags used as return values from our methods. Just for internal
-# clarification.
-my $YES = (1==1);
-my $NO = !$YES;
-
-=head1 NAME
-
-Test::Harness::Straps - detailed analysis of test results
-
-=head1 SYNOPSIS
-
- use Test::Harness::Straps;
-
- my $strap = Test::Harness::Straps->new;
-
- # Various ways to interpret a test
- my $results = $strap->analyze($name, \@test_output);
- my $results = $strap->analyze_fh($name, $test_filehandle);
- my $results = $strap->analyze_file($test_file);
-
- # UNIMPLEMENTED
- my %total = $strap->total_results;
-
- # Altering the behavior of the strap UNIMPLEMENTED
- my $verbose_output = $strap->dump_verbose();
- $strap->dump_verbose_fh($output_filehandle);
-
-
-=head1 DESCRIPTION
-
-B<THIS IS ALPHA SOFTWARE> in that the interface is subject to change
-in incompatible ways. It is otherwise stable.
-
-Test::Harness is limited to printing out its results. This makes
-analysis of the test results difficult for anything but a human. To
-make it easier for programs to work with test results, we provide
-Test::Harness::Straps. Instead of printing the results, straps
-provide them as raw data. You can also configure how the tests are to
-be run.
-
-The interface is currently incomplete. I<Please> contact the author
-if you'd like a feature added or something change or just have
-comments.
-
-=head1 CONSTRUCTION
-
-=head2 new()
-
- my $strap = Test::Harness::Straps->new;
-
-Initialize a new strap.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = bless {}, $class;
-
- $self->_init;
-
- return $self;
-}
-
-=for private $strap->_init
-
- $strap->_init;
-
-Initialize the internal state of a strap to make it ready for parsing.
-
-=cut
-
-sub _init {
- my($self) = shift;
-
- $self->{_is_vms} = ( $^O eq 'VMS' );
- $self->{_is_win32} = ( $^O =~ /^(MS)?Win32$/ );
- $self->{_is_macos} = ( $^O eq 'MacOS' );
-}
-
-=head1 ANALYSIS
-
-=head2 $strap->analyze( $name, \@output_lines )
-
- my $results = $strap->analyze($name, \@test_output);
-
-Analyzes the output of a single test, assigning it the given C<$name>
-for use in the total report. Returns the C<$results> of the test.
-See L<Results>.
-
-C<@test_output> should be the raw output from the test, including
-newlines.
-
-=cut
-
-sub analyze {
- my($self, $name, $test_output) = @_;
-
- my $it = Test::Harness::Iterator->new($test_output);
- return $self->_analyze_iterator($name, $it);
-}
-
-
-sub _analyze_iterator {
- my($self, $name, $it) = @_;
-
- $self->_reset_file_state;
- $self->{file} = $name;
-
- my $results = Test::Harness::Results->new;
-
- # Set them up here so callbacks can have them.
- $self->{totals}{$name} = $results;
- while( defined(my $line = $it->next) ) {
- $self->_analyze_line($line, $results);
- last if $self->{saw_bailout};
- }
-
- $results->set_skip_all( $self->{skip_all} ) if defined $self->{skip_all};
-
- my $passed =
- (($results->max == 0) && defined $results->skip_all) ||
- ($results->max &&
- $results->seen &&
- $results->max == $results->seen &&
- $results->max == $results->ok);
-
- $results->set_passing( $passed ? 1 : 0 );
-
- return $results;
-}
-
-
-sub _analyze_line {
- my $self = shift;
- my $line = shift;
- my $results = shift;
-
- $self->{line}++;
-
- my $linetype;
- my $point = Test::Harness::Point->from_test_line( $line );
- if ( $point ) {
- $linetype = 'test';
-
- $results->inc_seen;
- $point->set_number( $self->{'next'} ) unless $point->number;
-
- # sometimes the 'not ' and the 'ok' are on different lines,
- # happens often on VMS if you do:
- # print "not " unless $test;
- # print "ok $num\n";
- if ( $self->{lone_not_line} && ($self->{lone_not_line} == $self->{line} - 1) ) {
- $point->set_ok( 0 );
- }
-
- if ( $self->{todo}{$point->number} ) {
- $point->set_directive_type( 'todo' );
- }
-
- if ( $point->is_todo ) {
- $results->inc_todo;
- $results->inc_bonus if $point->ok;
- }
- elsif ( $point->is_skip ) {
- $results->inc_skip;
- }
-
- $results->inc_ok if $point->pass;
-
- if ( ($point->number > 100_000) && ($point->number > ($self->{max}||100_000)) ) {
- if ( !$self->{too_many_tests}++ ) {
- warn "Enormous test number seen [test ", $point->number, "]\n";
- warn "Can't detailize, too big.\n";
- }
- }
- else {
- my $details = {
- ok => $point->pass,
- actual_ok => $point->ok,
- name => _def_or_blank( $point->description ),
- type => _def_or_blank( $point->directive_type ),
- reason => _def_or_blank( $point->directive_reason ),
- };
-
- assert( defined( $details->{ok} ) && defined( $details->{actual_ok} ) );
- $results->set_details( $point->number, $details );
- }
- } # test point
- elsif ( $line =~ /^not\s+$/ ) {
- $linetype = 'other';
- # Sometimes the "not " and "ok" will be on separate lines on VMS.
- # We catch this and remember we saw it.
- $self->{lone_not_line} = $self->{line};
- }
- elsif ( $self->_is_header($line) ) {
- $linetype = 'header';
-
- $self->{saw_header}++;
-
- $results->inc_max( $self->{max} );
- }
- elsif ( $self->_is_bail_out($line, \$self->{bailout_reason}) ) {
- $linetype = 'bailout';
- $self->{saw_bailout} = 1;
- }
- elsif (my $diagnostics = $self->_is_diagnostic_line( $line )) {
- $linetype = 'other';
- # XXX We can throw this away, really.
- my $test = $results->details->[-1];
- $test->{diagnostics} ||= '';
- $test->{diagnostics} .= $diagnostics;
- }
- else {
- $linetype = 'other';
- }
-
- $self->callback->($self, $line, $linetype, $results) if $self->callback;
-
- $self->{'next'} = $point->number + 1 if $point;
-} # _analyze_line
-
-
-sub _is_diagnostic_line {
- my ($self, $line) = @_;
- return if index( $line, '# Looks like you failed' ) == 0;
- $line =~ s/^#\s//;
- return $line;
-}
-
-=for private $strap->analyze_fh( $name, $test_filehandle )
-
- my $results = $strap->analyze_fh($name, $test_filehandle);
-
-Like C<analyze>, but it reads from the given filehandle.
-
-=cut
-
-sub analyze_fh {
- my($self, $name, $fh) = @_;
-
- my $it = Test::Harness::Iterator->new($fh);
- return $self->_analyze_iterator($name, $it);
-}
-
-=head2 $strap->analyze_file( $test_file )
-
- my $results = $strap->analyze_file($test_file);
-
-Like C<analyze>, but it runs the given C<$test_file> and parses its
-results. It will also use that name for the total report.
-
-=cut
-
-sub analyze_file {
- my($self, $file) = @_;
-
- unless( -e $file ) {
- $self->{error} = "$file does not exist";
- return;
- }
-
- unless( -r $file ) {
- $self->{error} = "$file is not readable";
- return;
- }
-
- local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
- if ( $Test::Harness::Debug ) {
- local $^W=0; # ignore undef warnings
- print "# PERL5LIB=$ENV{PERL5LIB}\n";
- }
-
- # *sigh* this breaks under taint, but open -| is unportable.
- my $line = $self->_command_line($file);
-
- unless ( open(FILE, "$line|" )) {
- print "can't run $file. $!\n";
- return;
- }
-
- my $results = $self->analyze_fh($file, \*FILE);
- my $exit = close FILE;
-
- $results->set_wait($?);
- if ( $? && $self->{_is_vms} ) {
- $results->set_exit($?);
- }
- else {
- $results->set_exit( _wait2exit($?) );
- }
- $results->set_passing(0) unless $? == 0;
-
- $self->_restore_PERL5LIB();
-
- return $results;
-}
-
-
-eval { require POSIX; &POSIX::WEXITSTATUS(0) };
-if( $@ ) {
- *_wait2exit = sub { $_[0] >> 8 };
-}
-else {
- *_wait2exit = sub { POSIX::WEXITSTATUS($_[0]) }
-}
-
-=for private $strap->_command_line( $file )
-
-Returns the full command line that will be run to test I<$file>.
-
-=cut
-
-sub _command_line {
- my $self = shift;
- my $file = shift;
-
- my $command = $self->_command();
- my $switches = $self->_switches($file);
-
- $file = qq["$file"] if ($file =~ /\s/) && ($file !~ /^".*"$/);
- my $line = "$command $switches $file";
-
- return $line;
-}
-
-
-=for private $strap->_command()
-
-Returns the command that runs the test. Combine this with C<_switches()>
-to build a command line.
-
-Typically this is C<$^X>, but you can set C<$ENV{HARNESS_PERL}>
-to use a different Perl than what you're running the harness under.
-This might be to run a threaded Perl, for example.
-
-You can also overload this method if you've built your own strap subclass,
-such as a PHP interpreter for a PHP-based strap.
-
-=cut
-
-sub _command {
- my $self = shift;
-
- return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
- #return qq["$^X"] if $self->{_is_win32} && ($^X =~ /[^\w\.\/\\]/);
- return qq["$^X"] if $^X =~ /\s/ and $^X !~ /^["']/;
- return $^X;
-}
-
-
-=for private $strap->_switches( $file )
-
-Formats and returns the switches necessary to run the test.
-
-=cut
-
-sub _switches {
- my($self, $file) = @_;
-
- my @existing_switches = $self->_cleaned_switches( $Test::Harness::Switches, $ENV{HARNESS_PERL_SWITCHES} );
- my @derived_switches;
-
- local *TEST;
- open(TEST, $file) or print "can't open $file. $!\n";
- my $shebang = <TEST>;
- close(TEST) or print "can't close $file. $!\n";
-
- my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
- push( @derived_switches, "-$1" ) if $taint;
-
- # When taint mode is on, PERL5LIB is ignored. So we need to put
- # all that on the command line as -Is.
- # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
- if ( $taint || $self->{_is_macos} ) {
- my @inc = $self->_filtered_INC;
- push @derived_switches, map { "-I$_" } @inc;
- }
-
- # 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 ( @derived_switches ) {
- $_ = qq["$_"] if ((/\s/ || $self->{_is_vms}) && !/^".*"$/ );
- }
- return join( " ", @existing_switches, @derived_switches );
-}
-
-=for private $strap->_cleaned_switches( @switches_from_user )
-
-Returns only defined, non-blank, trimmed switches from the parms passed.
-
-=cut
-
-sub _cleaned_switches {
- my $self = shift;
-
- local $_;
-
- my @switches;
- for ( @_ ) {
- my $switch = $_;
- next unless defined $switch;
- $switch =~ s/^\s+//;
- $switch =~ s/\s+$//;
- push( @switches, $switch ) if $switch ne "";
- }
-
- return @switches;
-}
-
-=for private $strap->_INC2PERL5LIB
-
- local $ENV{PERL5LIB} = $self->_INC2PERL5LIB;
-
-Takes the current value of C<@INC> and turns it into something suitable
-for putting onto C<PERL5LIB>.
-
-=cut
-
-sub _INC2PERL5LIB {
- my($self) = shift;
-
- $self->{_old5lib} = $ENV{PERL5LIB};
-
- return join $Config{path_sep}, $self->_filtered_INC;
-}
-
-=for private $strap->_filtered_INC()
-
- my @filtered_inc = $self->_filtered_INC;
-
-Shortens C<@INC> by removing redundant and unnecessary entries.
-Necessary for OSes with limited command line lengths, like VMS.
-
-=cut
-
-sub _filtered_INC {
- my($self, @inc) = @_;
- @inc = @INC unless @inc;
-
- if( $self->{_is_vms} ) {
- # 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;
-
- }
- elsif ( $self->{_is_win32} ) {
- # Lose any trailing backslashes in the Win32 paths
- s/[\\\/+]$// foreach @inc;
- }
-
- my %seen;
- $seen{$_}++ foreach $self->_default_inc();
- @inc = grep !$seen{$_}++, @inc;
-
- return @inc;
-}
-
-
-{ # Without caching, _default_inc() takes a huge amount of time
- my %cache;
- sub _default_inc {
- my $self = shift;
- my $perl = $self->_command;
- $cache{$perl} ||= [do {
- local $ENV{PERL5LIB};
- my @inc =`$perl -le "print join qq[\\n], \@INC"`;
- chomp @inc;
- }];
- return @{$cache{$perl}};
- }
-}
-
-
-=for private $strap->_restore_PERL5LIB()
-
- $self->_restore_PERL5LIB;
-
-This restores the original value of the C<PERL5LIB> environment variable.
-Necessary on VMS, otherwise a no-op.
-
-=cut
-
-sub _restore_PERL5LIB {
- my($self) = shift;
-
- return unless $self->{_is_vms};
-
- if (defined $self->{_old5lib}) {
- $ENV{PERL5LIB} = $self->{_old5lib};
- }
-}
-
-=head1 Parsing
-
-Methods for identifying what sort of line you're looking at.
-
-=for private _is_diagnostic
-
- my $is_diagnostic = $strap->_is_diagnostic($line, \$comment);
-
-Checks if the given line is a comment. If so, it will place it into
-C<$comment> (sans #).
-
-=cut
-
-sub _is_diagnostic {
- my($self, $line, $comment) = @_;
-
- if( $line =~ /^\s*\#(.*)/ ) {
- $$comment = $1;
- return $YES;
- }
- else {
- return $NO;
- }
-}
-
-=for private _is_header
-
- my $is_header = $strap->_is_header($line);
-
-Checks if the given line is a header (1..M) line. If so, it places how
-many tests there will be in C<< $strap->{max} >>, a list of which tests
-are todo in C<< $strap->{todo} >> and if the whole test was skipped
-C<< $strap->{skip_all} >> contains the reason.
-
-=cut
-
-# Regex for parsing a header. Will be run with /x
-my $Extra_Header_Re = <<'REGEX';
- ^
- (?: \s+ todo \s+ ([\d \t]+) )? # optional todo set
- (?: \s* \# \s* ([\w:]+\s?) (.*) )? # optional skip with optional reason
-REGEX
-
-sub _is_header {
- my($self, $line) = @_;
-
- if( my($max, $extra) = $line =~ /^1\.\.(\d+)(.*)/ ) {
- $self->{max} = $max;
- assert( $self->{max} >= 0, 'Max # of tests looks right' );
-
- if( defined $extra ) {
- my($todo, $skip, $reason) = $extra =~ /$Extra_Header_Re/xo;
-
- $self->{todo} = { map { $_ => 1 } split /\s+/, $todo } if $todo;
-
- if( $self->{max} == 0 ) {
- $reason = '' unless defined $skip and $skip =~ /^Skip/i;
- }
-
- $self->{skip_all} = $reason;
- }
-
- return $YES;
- }
- else {
- return $NO;
- }
-}
-
-=for private _is_bail_out
-
- my $is_bail_out = $strap->_is_bail_out($line, \$reason);
-
-Checks if the line is a "Bail out!". Places the reason for bailing
-(if any) in $reason.
-
-=cut
-
-sub _is_bail_out {
- my($self, $line, $reason) = @_;
-
- if( $line =~ /^Bail out!\s*(.*)/i ) {
- $$reason = $1 if $1;
- return $YES;
- }
- else {
- return $NO;
- }
-}
-
-=for private _reset_file_state
-
- $strap->_reset_file_state;
-
-Resets things like C<< $strap->{max} >> , C<< $strap->{skip_all} >>,
-etc. so it's ready to parse the next file.
-
-=cut
-
-sub _reset_file_state {
- my($self) = shift;
-
- delete @{$self}{qw(max skip_all todo too_many_tests)};
- $self->{line} = 0;
- $self->{saw_header} = 0;
- $self->{saw_bailout}= 0;
- $self->{lone_not_line} = 0;
- $self->{bailout_reason} = '';
- $self->{'next'} = 1;
-}
-
-=head1 EXAMPLES
-
-See F<examples/mini_harness.plx> for an example of use.
-
-=head1 AUTHOR
-
-Michael G Schwern C<< <schwern at pobox.com> >>, currently maintained by
-Andy Lester C<< <andy at petdance.com> >>.
-
-=head1 SEE ALSO
-
-L<Test::Harness>
-
-=cut
-
-sub _def_or_blank {
- return $_[0] if defined $_[0];
- return "";
-}
-
-sub set_callback {
- my $self = shift;
- $self->{callback} = shift;
-}
-
-sub callback {
- my $self = shift;
- return $self->{callback};
-}
-
-1;
+++ /dev/null
-=head1 NAME
-
-Test::Harness::TAP - Documentation for the TAP format
-
-=head1 SYNOPSIS
-
-TAP, the Test Anything Protocol, is Perl's simple text-based interface
-between testing modules such as Test::More and the test harness
-Test::Harness.
-
-=head1 TODO
-
-Exit code of the process.
-
-=head1 THE TAP FORMAT
-
-TAP's general format is:
-
- 1..N
- ok 1 Description # Directive
- # Diagnostic
- ....
- ok 47 Description
- ok 48 Description
- more tests....
-
-For example, a test file's output might look like:
-
- 1..4
- ok 1 - Input file opened
- not ok 2 - First line of the input valid
- ok 3 - Read the rest of the file
- not ok 4 - Summarized correctly # TODO Not written yet
-
-=head1 HARNESS BEHAVIOR
-
-In this document, the "harness" is any program analyzing TAP output.
-Typically this will be Perl's I<prove> program, or the underlying
-C<Test::Harness::runtests> subroutine.
-
-A harness must only read TAP output from standard output and not
-from standard error. Lines written to standard output matching
-C</^(not )?ok\b/> must be interpreted as test lines. All other
-lines must not be considered test output.
-
-=head1 TESTS LINES AND THE PLAN
-
-=head2 The plan
-
-The plan tells how many tests will be run, or how many tests have
-run. It's a check that the test file hasn't stopped prematurely.
-It must appear once, whether at the beginning or end of the output.
-
-The plan is usually the first line of TAP output and it specifies how
-many test points are to follow. For example,
-
- 1..10
-
-means you plan on running 10 tests. This is a safeguard in case your test
-file dies silently in the middle of its run. The plan is optional but if
-there is a plan before the test points it must be the first non-diagnostic
-line output by the test file.
-
-In certain instances a test file may not know how many test points
-it will ultimately be running. In this case the plan can be the last
-non-diagnostic line in the output.
-
-The plan cannot appear in the middle of the output, nor can it appear more
-than once.
-
-=head2 The test line
-
-The core of TAP is the test line. A test file prints one test line test
-point executed. There must be at least one test line in TAP output. Each
-test line comprises the following elements:
-
-=over 4
-
-=item * C<ok> or C<not ok>
-
-This tells whether the test point passed or failed. It must be
-at the beginning of the line. C</^not ok/> indicates a failed test
-point. C</^ok/> is a successful test point. This is the only mandatory
-part of the line.
-
-Note that unlike the Directives below, C<ok> and C<not ok> are
-case-sensitive.
-
-=item * Test number
-
-TAP expects the C<ok> or C<not ok> to be followed by a test point
-number. If there is no number the harness must maintain
-its own counter until the script supplies test numbers again. So
-the following test output
-
- 1..6
- not ok
- ok
- not ok
- ok
- ok
-
-has five tests. The sixth is missing. Test::Harness will generate
-
- FAILED tests 1, 3, 6
- Failed 3/6 tests, 50.00% okay
-
-=item * Description
-
-Any text after the test number but before a C<#> is the description of
-the test point.
-
- ok 42 this is the description of the test
-
-Descriptions should not begin with a digit so that they are not confused
-with the test point number.
-
-The harness may do whatever it wants with the description.
-
-=item * Directive
-
-The test point may include a directive, following a hash on the
-test line. There are currently two directives allowed: C<TODO> and
-C<SKIP>. These are discussed below.
-
-=back
-
-To summarize:
-
-=over 4
-
-=item * ok/not ok (required)
-
-=item * Test number (recommended)
-
-=item * Description (recommended)
-
-=item * Directive (only when necessary)
-
-=back
-
-=head1 DIRECTIVES
-
-Directives are special notes that follow a C<#> on the test line.
-Only two are currently defined: C<TODO> and C<SKIP>. Note that
-these two keywords are not case-sensitive.
-
-=head2 TODO tests
-
-If the directive starts with C<# TODO>, the test is counted as a
-todo test, and the text after C<TODO> is the explanation.
-
- not ok 13 # TODO bend space and time
-
-Note that if the TODO has an explanation it must be separated from
-C<TODO> by a space.
-
-These tests represent a feature to be implemented or a bug to be fixed
-and act as something of an executable "things to do" list. They are
-B<not> expected to succeed. Should a todo test point begin succeeding,
-the harness should report it as a bonus. This indicates that whatever
-you were supposed to do has been done and you should promote this to a
-normal test point.
-
-=head2 Skipping tests
-
-If the directive starts with C<# SKIP>, the test is counted as having
-been skipped. If the whole test file succeeds, the count of skipped
-tests is included in the generated output. The harness should report
-the text after C< # SKIP\S*\s+> as a reason for skipping.
-
- ok 23 # skip Insufficient flogiston pressure.
-
-Similarly, one can include an explanation in a plan line,
-emitted if the test file is skipped completely:
-
- 1..0 # Skipped: WWW::Mechanize not installed
-
-=head1 OTHER LINES
-
-=head2 Bail out!
-
-As an emergency measure a test script can decide that further tests
-are useless (e.g. missing dependencies) and testing should stop
-immediately. In that case the test script prints the magic words
-
- Bail out!
-
-to standard output. Any message after these words must be displayed
-by the interpreter as the reason why testing must be stopped, as
-in
-
- Bail out! MySQL is not running.
-
-=head2 Diagnostics
-
-Additional information may be put into the testing output on separate
-lines. Diagnostic lines should begin with a C<#>, which the harness must
-ignore, at least as far as analyzing the test results. The harness is
-free, however, to display the diagnostics. Typically diagnostics are
-used to provide information about the environment in which test file is
-running, or to delineate a group of tests.
-
- ...
- ok 18 - Closed database connection
- # End of database section.
- # This starts the network part of the test.
- # Daemon started on port 2112
- ok 19 - Opened socket
- ...
- ok 47 - Closed socket
- # End of network tests
-
-=head2 Anything else
-
-Any output line that is not a plan, a test line or a diagnostic is
-incorrect. How a harness handles the incorrect line is undefined.
-Test::Harness silently ignores incorrect lines, but will become more
-stringent in the future.
-
-=head1 EXAMPLES
-
-All names, places, and events depicted in any example are wholly
-fictitious and bear no resemblance to, connection with, or relation to any
-real entity. Any such similarity is purely coincidental, unintentional,
-and unintended.
-
-=head2 Common with explanation
-
-The following TAP listing declares that six tests follow as well as
-provides handy feedback as to what the test is about to do. All six
-tests pass.
-
- 1..6
- #
- # Create a new Board and Tile, then place
- # the Tile onto the board.
- #
- ok 1 - The object isa Board
- ok 2 - Board size is zero
- ok 3 - The object isa Tile
- ok 4 - Get possible places to put the Tile
- ok 5 - Placing the tile produces no error
- ok 6 - Board size is 1
-
-=head2 Unknown amount and failures
-
-This hypothetical test program ensures that a handful of servers are
-online and network-accessible. Because it retrieves the hypothetical
-servers from a database, it doesn't know exactly how many servers it
-will need to ping. Thus, the test count is declared at the bottom after
-all the test points have run. Also, two of the tests fail.
-
- ok 1 - retrieving servers from the database
- # need to ping 6 servers
- ok 2 - pinged diamond
- ok 3 - pinged ruby
- not ok 4 - pinged saphire
- ok 5 - pinged onyx
- not ok 6 - pinged quartz
- ok 7 - pinged gold
- 1..7
-
-=head2 Giving up
-
-This listing reports that a pile of tests are going to be run. However,
-the first test fails, reportedly because a connection to the database
-could not be established. The program decided that continuing was
-pointless and exited.
-
- 1..573
- not ok 1 - database handle
- Bail out! Couldn't connect to database.
-
-=head2 Skipping a few
-
-The following listing plans on running 5 tests. However, our program
-decided to not run tests 2 thru 5 at all. To properly report this,
-the tests are marked as being skipped.
-
- 1..5
- ok 1 - approved operating system
- # $^0 is solaris
- ok 2 - # SKIP no /sys directory
- ok 3 - # SKIP no /sys directory
- ok 4 - # SKIP no /sys directory
- ok 5 - # SKIP no /sys directory
-
-=head2 Skipping everything
-
-This listing shows that the entire listing is a skip. No tests were run.
-
- 1..0 # skip because English-to-French translator isn't installed
-
-=head2 Got spare tuits?
-
-The following example reports that four tests are run and the last two
-tests failed. However, because the failing tests are marked as things
-to do later, they are considered successes. Thus, a harness should report
-this entire listing as a success.
-
- 1..4
- ok 1 - Creating test program
- ok 2 - Test program runs, no error
- not ok 3 - infinite loop # TODO halting problem unsolved
- not ok 4 - infinite loop 2 # TODO halting problem unsolved
-
-=head2 Creative liberties
-
-This listing shows an alternate output where the test numbers aren't
-provided. The test also reports the state of a ficticious board game in
-diagnostic form. Finally, the test count is reported at the end.
-
- ok - created Board
- ok
- ok
- ok
- ok
- ok
- ok
- ok
- # +------+------+------+------+
- # | |16G | |05C |
- # | |G N C | |C C G |
- # | | G | | C +|
- # +------+------+------+------+
- # |10C |01G | |03C |
- # |R N G |G A G | |C C C |
- # | R | G | | C +|
- # +------+------+------+------+
- # | |01G |17C |00C |
- # | |G A G |G N R |R N R |
- # | | G | R | G |
- # +------+------+------+------+
- ok - board has 7 tiles + starter tile
- 1..9
-
-=head1 Non-Perl TAP
-
-In Perl, we use Test::Simple and Test::More to generate TAP output.
-Other languages have solutions that generate TAP, so that they can take
-advantage of Test::Harness.
-
-The following sections are provided by their maintainers, and may not
-be up-to-date.
-
-=head2 C/C++
-
-libtap makes it easy to write test programs in C that produce
-TAP-compatible output. Modeled on the Test::More API, libtap contains
-all the functions you need to:
-
-=over 4
-
-=item * Specify a test plan
-
-=item * Run tests
-
-=item * Skip tests in certain situations
-
-=item * Have TODO tests
-
-=item * Produce TAP compatible diagnostics
-
-=back
-
-More information about libtap, including download links, checksums,
-anonymous access to the Subersion repository, and a bug tracking
-system, can be found at:
-
- http://jc.ngo.org.uk/trac-bin/trac.cgi/wiki/LibTap
-
-(Nik Clayton, April 17, 2006)
-
-=head2 Python
-
-PyTap will, when it's done, provide a simple, assertive (Test::More-like)
-interface for writing tests in Python. It will output TAP and will
-include the functionality found in Test::Builder and Test::More. It will
-try to make it easy to add more test code (so you can write your own
-C<TAP.StringDiff>, for example.
-
-Right now, it's got a fair bit of the basics needed to emulate Test::More,
-and I think it's easy to add more stuff -- just like Test::Builder,
-there's a singleton that you can get at easily.
-
-I need to better identify and finish implementing the most basic tests.
-I am not a Python guru, I just use it from time to time, so my aim may
-not be true. I need to write tests for it, which means either relying
-on Perl for the tester tester, or writing one in Python.
-
-Here's a sample test, as found in my Subversion:
-
- from TAP.Simple import *
-
- plan(15)
-
- ok(1)
- ok(1, "everything is OK!")
- ok(0, "always fails")
-
- is_ok(10, 10, "is ten ten?")
- is_ok(ok, ok, "even ok is ok!")
- ok(id(ok), "ok is not the null pointer")
- ok(True, "the Truth will set you ok")
- ok(not False, "and nothing but the truth")
- ok(False, "and we'll know if you lie to us")
-
- isa_ok(10, int, "10")
- isa_ok('ok', str, "some string")
-
- ok(0, "zero is true", todo="be more like Ruby!")
- ok(None, "none is true", skip="not possible in this universe")
-
- eq_ok("not", "equal", "two strings are not equal");
-
-(Ricardo Signes, April 17, 2006)
-
-=head2 JavaScript
-
-Test.Simple looks and acts just like TAP, although in reality it's
-tracking test results in an object rather than scraping them from a
-print buffer.
-
- http://openjsan.org/doc/t/th/theory/Test/Simple/
-
-(David Wheeler, April 17, 2006)
-
-=head2 PHP
-
-All the big PHP players now produce TAP
-
-=over
-
-=item * phpt
-
-Outputs TAP by default as of the yet-to-be-released PEAR 1.5.0
-
- http://pear.php.net/PEAR
-
-=item * PHPUnit
-
-Has a TAP logger (since 2.3.4)
-
- http://www.phpunit.de/wiki/Main_Page
-
-=item * SimpleTest
-
-There's a third-party TAP reporting extension for SimpleTest
-
- http://www.digitalsandwich.com/archives/51-Updated-Simpletest+Apache-Test.html
-
-=item * Apache-Test
-
-Apache-Test's PHP writes TAP by default and includes the standalone
-test-more.php
-
- http://search.cpan.org/dist/Apache-Test/
-
-=back
-
-(Geoffrey Young, April 17, 2006)
-
-=head1 AUTHORS
-
-Andy Lester, based on the original Test::Harness documentation by Michael Schwern.
-
-=head1 ACKNOWLEDGEMENTS
-
-Thanks to
-Pete Krawczyk,
-Paul Johnson,
-Ian Langworth
-and Nik Clayton
-for help and contributions on this document.
-
-The basis for the TAP format was created by Larry Wall in the
-original test script for Perl 1. Tim Bunce and Andreas Koenig
-developed it further with their modifications to Test::Harness.
-
-=head1 COPYRIGHT
-
-Copyright 2003-2005 by
-Michael G Schwern C<< <schwern@pobox.com> >>,
-Andy Lester C<< <andy@petdance.com> >>.
-
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>.
-
-=cut
+++ /dev/null
-package Test::Harness::Util;
-
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.01';
-
-use File::Spec;
-use Exporter;
-use vars qw( @ISA @EXPORT @EXPORT_OK );
-
-@ISA = qw( Exporter );
-@EXPORT = ();
-@EXPORT_OK = qw( all_in shuffle blibdirs );
-
-=head1 NAME
-
-Test::Harness::Util - Utility functions for Test::Harness::*
-
-=head1 SYNOPSIS
-
-Utility functions for Test::Harness::*
-
-=head1 PUBLIC FUNCTIONS
-
-The following are all available to be imported to your module. No symbols
-are exported by default.
-
-=head2 all_in( {parm => value, parm => value} )
-
-Finds all the F<*.t> in a directory. Knows to skip F<.svn> and F<CVS>
-directories.
-
-Valid parms are:
-
-=over
-
-=item start
-
-Starting point for the search. Defaults to ".".
-
-=item recurse
-
-Flag to say whether it should recurse. Default to true.
-
-=back
-
-=cut
-
-sub all_in {
- my $parms = shift;
- my %parms = (
- start => ".",
- recurse => 1,
- %$parms,
- );
-
- my @hits = ();
- my $start = $parms{start};
-
- local *DH;
- if ( opendir( DH, $start ) ) {
- my @files = sort readdir DH;
- closedir DH;
- for my $file ( @files ) {
- next if $file eq File::Spec->updir || $file eq File::Spec->curdir;
- next if $file eq ".svn";
- next if $file eq "CVS";
-
- my $currfile = File::Spec->catfile( $start, $file );
- if ( -d $currfile ) {
- push( @hits, all_in( { %parms, start => $currfile } ) ) if $parms{recurse};
- }
- else {
- push( @hits, $currfile ) if $currfile =~ /\.t$/;
- }
- }
- }
- else {
- warn "$start: $!\n";
- }
-
- return @hits;
-}
-
-=head1 shuffle( @list )
-
-Returns a shuffled copy of I<@list>.
-
-=cut
-
-sub shuffle {
- # Fisher-Yates shuffle
- my $i = @_;
- while ($i) {
- my $j = rand $i--;
- @_[$i, $j] = @_[$j, $i];
- }
-}
-
-
-=head2 blibdir()
-
-Finds all the blib directories. Stolen directly from blib.pm
-
-=cut
-
-sub blibdirs {
- my $dir = File::Spec->curdir;
- if ($^O eq 'VMS') {
- ($dir = VMS::Filespec::unixify($dir)) =~ s-/\z--;
- }
- my $archdir = "arch";
- if ( $^O eq "MacOS" ) {
- # Double up the MP::A so that it's not used only once.
- $archdir = $MacPerl::Architecture = $MacPerl::Architecture;
- }
-
- my $i = 5;
- while ($i--) {
- my $blib = File::Spec->catdir( $dir, "blib" );
- my $blib_lib = File::Spec->catdir( $blib, "lib" );
- my $blib_arch = File::Spec->catdir( $blib, $archdir );
-
- if ( -d $blib && -d $blib_arch && -d $blib_lib ) {
- return ($blib_arch,$blib_lib);
- }
- $dir = File::Spec->catdir($dir, File::Spec->updir);
- }
- warn "$0: Cannot find blib\n";
- return;
-}
-
-1;
#!/usr/bin/perl -w
use strict;
+use App::Prove;
-use Test::Harness;
-use Test::Harness::Util qw( all_in blibdirs shuffle );
-
-use Getopt::Long;
-use Pod::Usage 1.12;
-use File::Spec;
-
-use vars qw( $VERSION );
-$VERSION = '2.64';
-
-my $shuffle = 0;
-my $dry = 0;
-my $blib = 0;
-my $lib = 0;
-my $recurse = 0;
-my @includes = ();
-my @switches = ();
-
-# Allow cuddling the paths with the -I
-@ARGV = map { /^(-I)(.+)/ ? ($1,$2) : $_ } @ARGV;
-
-# Stick any default switches at the beginning, so they can be overridden
-# by the command line switches.
-unshift @ARGV, split( ' ', $ENV{PROVE_SWITCHES} ) if defined $ENV{PROVE_SWITCHES};
-
-Getopt::Long::Configure( 'no_ignore_case' );
-Getopt::Long::Configure( 'bundling' );
-GetOptions(
- 'b|blib' => \$blib,
- 'd|debug' => \$Test::Harness::debug,
- 'D|dry' => \$dry,
- 'h|help|?' => sub {pod2usage({-verbose => 1}); exit},
- 'H|man' => sub {pod2usage({-verbose => 2}); exit},
- 'I=s@' => \@includes,
- 'l|lib' => \$lib,
- 'perl=s' => \$ENV{HARNESS_PERL},
- 'r|recurse' => \$recurse,
- 's|shuffle' => \$shuffle,
- 't' => sub { unshift @switches, '-t' }, # Always want -t up front
- 'T' => sub { unshift @switches, '-T' }, # Always want -T up front
- 'w' => sub { push @switches, '-w' },
- 'W' => sub { push @switches, '-W' },
- 'strap=s' => \$ENV{HARNESS_STRAP_CLASS},
- 'timer' => \$Test::Harness::Timer,
- 'v|verbose' => \$Test::Harness::verbose,
- 'V|version' => sub { print_version(); exit; },
-) or exit 1;
-
-$ENV{TEST_VERBOSE} = 1 if $Test::Harness::verbose;
-
-# Handle blib includes
-if ( $blib ) {
- my @blibdirs = blibdirs();
- if ( @blibdirs ) {
- unshift @includes, @blibdirs;
- }
- else {
- warn "No blib directories found.\n";
- }
-}
-
-# Handle lib includes
-if ( $lib ) {
- unshift @includes, 'lib';
-}
-
-# Build up TH switches
-push( @switches, map { /\s/ && !/^".*"$/ ? qq["-I$_"] : "-I$_" } @includes );
-$Test::Harness::Switches = join( ' ', @switches );
-print "# \$Test::Harness::Switches: $Test::Harness::Switches\n" if $Test::Harness::debug;
-
-@ARGV = File::Spec->curdir unless @ARGV;
-my @argv_globbed;
-my @tests;
-if ( $] >= 5.006001 ) {
- require File::Glob;
- @argv_globbed = map { File::Glob::bsd_glob($_) } @ARGV;
-}
-else {
- @argv_globbed = map { glob } @ARGV;
-}
-
-for ( @argv_globbed ) {
- push( @tests, -d $_ ? all_in( { recurse => $recurse, start => $_ } ) : $_ )
-}
-
-if ( @tests ) {
- shuffle(@tests) if $shuffle;
- if ( $dry ) {
- print join( "\n", @tests, '' );
- }
- else {
- print "# ", scalar @tests, " tests to run\n" if $Test::Harness::debug;
- runtests(@tests);
- }
-}
-
-sub print_version {
- printf( "prove v%s, using Test::Harness v%s and Perl v%vd\n",
- $VERSION, $Test::Harness::VERSION, $^V );
-}
+my $app = App::Prove->new;
+$app->process_args(@ARGV);
+$app->run;
__END__
=head1 NAME
-prove -- A command-line tool for running tests against Test::Harness
+prove - Run tests through a TAP harness.
-=head1 SYNOPSIS
+=head1 USAGE
-prove [options] [files/directories]
+ prove [options] [files or directories]
=head1 OPTIONS
- -b, --blib Adds blib/lib to the path for your tests, a la "use blib"
- -d, --debug Includes extra debugging information
- -D, --dry Dry run: Show the tests to run, but don't run them
- -h, --help Display this help
- -H, --man Longer manpage for prove
- -I Add libraries to @INC, as Perl's -I
- -l, --lib Add lib to the path for your tests
- --perl Sets the name of the Perl executable to use
- -r, --recurse Recursively descend into directories
- -s, --shuffle Run the tests in a random order
- --strap Define strap class to use
- -T Enable tainting checks
- -t Enable tainting warnings
- --timer Print elapsed time after each test file
- -v, --verbose Display standard output of test scripts while running them
- -V, --version Display version info
+Boolean options:
-Single-character options may be stacked. Default options may be set by
-specifying the PROVE_SWITCHES environment variable.
+ -v, --verbose Print all test lines.
+ -l, --lib Add 'lib' to the path for your tests (-Ilib).
+ -b, --blib Add 'blib/lib' to the path for your tests (-Iblib/lib).
+ -s, --shuffle Run the tests in random order.
+ -c, --color Colored test output (default).
+ --nocolor Do not color test output.
+ -f, --failures Only show failed tests.
+ --fork Fork to run harness in multiple processes
+ -m, --merge Merge test scripts' STDERR with their STDOUT.
+ -r, --recurse Recursively descend into directories.
+ --reverse Run the tests in reverse order.
+ -q, --quiet Suppress some test output while running tests.
+ -Q, --QUIET Only print summary results.
+ -p, --parse Show full list of TAP parse errors, if any.
+ --directives Only show results with TODO or SKIP directives.
+ --timer Print elapsed time after each test.
+ -T Enable tainting checks.
+ -t Enable tainting warnings.
+ -W Enable fatal warnings.
+ -w Enable warnings.
+ -h, --help Display this help
+ -?, Display this help
+ -H, --man Longer manpage for prove
+ --norc Don't process default .proverc
-=head1 OVERVIEW
+Options that take arguments:
-F<prove> is a command-line interface to the test-running functionality
-of C<Test::Harness>. With no arguments, it will run all tests in the
-current directory.
+ -I Library paths to include.
+ -P Load plugin (searches App::Prove::Plugin::*.)
+ -M Load a module.
+ -e, --exec Interpreter to run the tests ('' for compiled tests.)
+ --harness Define test harness to use. See TAP::Harness.
+ --formatter Result formatter to use. See TAP::Harness.
+ -a, --archive Store the resulting TAP in an archive file.
+ -j, --jobs N Run N test jobs in parallel (try 9.)
+ --state=opts Control prove's persistent state.
+ --rc=rcfile Process options from rcfile
-Shell metacharacters may be used with command lines options and will be exanded
-via C<File::Glob::bsd_glob>.
+=head1 NOTES
-=head1 PROVE VS. "MAKE TEST"
+=head2 .proverc
-F<prove> has a number of advantages over C<make test> when doing development.
+If F<~/.proverc> or F<./.proverc> exist they will be read and any
+options they contain processed before the command line options. Options
+in F<.proverc> are specified in the same way as command line options:
-=over 4
+ # .proverc
+ --state=hot,fast,save
+ -j9 --fork
-=item * F<prove> is designed as a development tool
+Additional option files may be specified with the C<--rc> option.
+Default option file processing is disabled by the C<--norc> option.
-Perl users typically run the test harness through a makefile via
-C<make test>. That's fine for module distributions, but it's
-suboptimal for a test/code/debug development cycle.
+Under Windows and VMS the option file is named F<_proverc> rather than
+F<.proverc> and is sought only in the current directory.
-=item * F<prove> is granular
+=head2 Reading from C<STDIN>
-F<prove> lets your run against only the files you want to check.
-Running C<prove t/live/ t/master.t> checks every F<*.t> in F<t/live>,
-plus F<t/master.t>.
+If you have a list of tests (or URLs, or anything else you want to test) in a
+file, you can add them to your tests by using a '-':
-=item * F<prove> has an easy verbose mode
+ prove - < my_list_of_things_to_test.txt
-F<prove> has a C<-v> option to see the raw output from the tests.
-To do this with C<make test>, you must set C<HARNESS_VERBOSE=1> in
-the environment.
+See the C<README> in the C<examples> directory of this distribution.
-=item * F<prove> can run under taint mode
+=head2 Default Test Directory
-F<prove>'s C<-T> runs your tests under C<perl -T>, and C<-t> runs them
-under C<perl -t>.
+If no files or directories are supplied, C<prove> looks for all files
+matching the pattern C<t/*.t>.
-=item * F<prove> can shuffle tests
+=head2 Colored Test Output
-You can use F<prove>'s C<--shuffle> option to try to excite problems
-that don't show up when tests are run in the same order every time.
+Colored test output is the default, but if output is not to a
+terminal, color is disabled. You can override this by adding the
+C<--color> switch.
-=item * F<prove> doesn't rely on a make tool
+Color support requires L<Term::ANSIColor> on Unix-like platforms and
+L<Win32::Console> windows. If the necessary module is not installed
+colored output will not be available.
-Not everyone wants to write a makefile, or use L<ExtUtils::MakeMaker>
-to do so. F<prove> has no external dependencies.
+=head2 Arguments to Tests
-=item * Not everything is a module
+It is possible to supply arguments to tests. To do so separate them from
+prove's own arguments with the arisdottle, '::'. For example
-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 -v t/mytest.t :: --url http://example.com
+
+would run F<t/mytest.t> with the options '--url http://example.com'.
+When running multiple tests they will each receive the same arguments.
-=back
+=head2 C<--exec>
-=head1 COMMAND LINE OPTIONS
+Normally you can just pass a list of Perl tests and the harness will know how
+to execute them. However, if your tests are not written in Perl or if you
+want all tests invoked exactly the same way, use the C<-e>, or C<--exec>
+switch:
-=head2 -b, --blib
+ prove --exec '/usr/bin/ruby -w' t/
+ prove --exec '/usr/bin/perl -Tw -mstrict -Ilib' t/
+ prove --exec '/path/to/my/customer/exec'
-Adds blib/lib to the path for your tests, a la "use blib".
+=head2 C<--merge>
-=head2 -d, --debug
+If you need to make sure your diagnostics are displayed in the correct
+order relative to test results you can use the C<--merge> option to
+merge the test scripts' STDERR into their STDOUT.
-Include debug information about how F<prove> is being run. This
-option doesn't show the output from the test scripts. That's handled
-by -v,--verbose.
+This guarantees that STDOUT (where the test results appear) and STDOUT
+(where the diagnostics appear) will stay in sync. The harness will
+display any diagnostics your tests emit on STDERR.
-=head2 -D, --dry
+Caveat: this is a bit of a kludge. In particular note that if anything
+that appears on STDERR looks like a test result the test harness will
+get confused. Use this option only if you understand the consequences
+and can live with the risk.
-Dry run: Show the tests to run, but don't run them.
+=head2 C<--state>
-=head2 -I
+You can ask C<prove> to remember the state of previous test runs and
+select and/or order the tests to be run this time based on that
+saved state.
-Add libraries to @INC, as Perl's -I.
+The C<--state> switch requires an argument which must be a comma
+separated list of one or more of the following options.
-=head2 -l, --lib
+=over
-Add C<lib> to @INC. Equivalent to C<-Ilib>.
+=item C<last>
-=head2 --perl
+Run the same tests as the last time the state was saved. This makes it
+possible, for example, to recreate the ordering of a shuffled test.
-Sets the C<HARNESS_PERL> environment variable, which controls what
-Perl executable will run the tests.
+ # Run all tests in random order
+ $ prove -b --state=save --shuffle
-=head2 -r, --recurse
+ # Run them again in the same order
+ $ prove -b --state=last
-Descends into subdirectories of any directories specified, looking for tests.
+=item C<failed>
-=head2 -s, --shuffle
+Run only the tests that failed on the last run.
-Sometimes tests are accidentally dependent on tests that have been
-run before. This switch will shuffle the tests to be run prior to
-running them, thus ensuring that hidden dependencies in the test
-order are likely to be revealed. The author hopes the run the
-algorithm on the preceding sentence to see if he can produce something
-slightly less awkward.
+ # Run all tests
+e $ prove -b --state=save
+
+ # Run failures
+ $ prove -b --state=failed
-=head2 --strap
+If you also specify the C<save> option newly passing tests will be
+excluded from subsequent runs.
-Sets the HARNESS_STRAP_CLASS variable to set which Test::Harness::Straps
-variable to use in running the tests.
+ # Repeat until no more failures
+ $ prove -b --state=failed,save
-=head2 -t
+=item C<passed>
-Runs test programs under perl's -t taint warning mode.
+Run only the passed tests from last time. Useful to make sure that no
+new problems have been introduced.
-=head2 -T
+=item C<all>
-Runs test programs under perl's -T taint mode.
+Run all tests in normal order. Multple options may be specified, so to
+run all tests with the failures from last time first:
-=head2 --timer
+ $ prove -b --state=failed,all,save
-Print elapsed time after each test file
+=item C<hot>
-=head2 -v, --verbose
+Run the tests that most recently failed first. The last failure time of
+each test is stored. The C<hot> option causes tests to be run in most-recent-
+failure order.
-Display standard output of test scripts while running them. Also sets
-TEST_VERBOSE in case your tests rely on them.
+ $ prove -b --state=hot,save
-=head2 -V, --version
+Tests that have never failed will not be selected. To run all tests with
+the most recently failed first use
-Display version info.
+ $ prove -b --state=hot,all,save
-=head1 BUGS
+This combination of options may also be specified thus
-Please use the CPAN bug ticketing system at L<http://rt.cpan.org/>.
-You can also mail bugs, fixes and enhancements to
-C<< <bug-test-harness@rt.cpan.org> >>.
+ $ prove -b --state=adrian
-=head1 TODO
+=item C<todo>
-=over 4
+Run any tests with todos.
-=item *
+=item C<slow>
-Shuffled tests must be recreatable
+Run the tests in slowest to fastest order. This is useful in conjunction
+with the C<-j> parallel testing switch to ensure that your slowest tests
+start running first.
-=back
+ $ prove -b --state=slow -j9
+
+=item C<fast>
-=head1 AUTHORS
+Run test tests in fastest to slowest order.
-Andy Lester C<< <andy at petdance.com> >>
+=item C<new>
-=head1 COPYRIGHT
+Run the tests in newest to oldest order.
-Copyright 2004-2006 by Andy Lester C<< <andy at petdance.com> >>.
+=item C<old>
-This program is free software; you can redistribute it and/or
-modify it under the same terms as Perl itself.
+Run the tests in oldest to newest order.
-See L<http://www.perl.com/perl/misc/Artistic.html>.
+=item C<save>
+
+Save the state on exit. The state is stored in a file called F<.prove>
+(F<_prove> on Windows and VMS) in the current directory.
+
+=back
+
+The C<--state> switch may be used more than once.
+
+ $ prove -b --state=hot --state=all,save
=cut
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 58;
+
+BEGIN {
+
+ # TAP::Parser must come first
+ my @classes = qw(
+ TAP::Parser
+ App::Prove
+ App::Prove::State
+ TAP::Base
+ TAP::Formatter::Color
+ TAP::Formatter::Console::ParallelSession
+ TAP::Formatter::Console::Session
+ TAP::Formatter::Console
+ TAP::Harness
+ TAP::Parser::Aggregator
+ TAP::Parser::Grammar
+ TAP::Parser::Iterator::Array
+ TAP::Parser::Iterator::Process
+ TAP::Parser::Iterator::Stream
+ TAP::Parser::Iterator
+ TAP::Parser::Multiplexer
+ TAP::Parser::Result::Bailout
+ TAP::Parser::Result::Comment
+ TAP::Parser::Result::Plan
+ TAP::Parser::Result::Test
+ TAP::Parser::Result::Unknown
+ TAP::Parser::Result::Version
+ TAP::Parser::Result::YAML
+ TAP::Parser::Result
+ TAP::Parser::Source::Perl
+ TAP::Parser::Source
+ TAP::Parser::YAMLish::Reader
+ TAP::Parser::YAMLish::Writer
+ Test::Harness
+ );
+
+ foreach my $class (@classes) {
+ use_ok $class or BAIL_OUT("Could not load $class");
+ is $class->VERSION, TAP::Parser->VERSION,
+ "... and $class should have the correct version";
+ }
+ diag("Testing Test::Harness $Test::Harness::VERSION, Perl $], $^X");
+}
--- /dev/null
+#!/usr/bin/perl -wT
+
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 79;
+
+use TAP::Parser;
+use TAP::Parser::Iterator;
+use TAP::Parser::Aggregator;
+
+my $tap = <<'END_TAP';
+1..5
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+END_TAP
+
+my $stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+isa_ok $stream, 'TAP::Parser::Iterator';
+
+my $parser1 = TAP::Parser->new( { stream => $stream } );
+isa_ok $parser1, 'TAP::Parser';
+
+$parser1->run;
+
+$tap = <<'END_TAP';
+1..7
+ok 1 - gentlemen, start your engines
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+my $parser2 = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser2, 'TAP::Parser';
+$parser2->run;
+
+can_ok 'TAP::Parser::Aggregator', 'new';
+my $agg = TAP::Parser::Aggregator->new;
+isa_ok $agg, 'TAP::Parser::Aggregator';
+
+can_ok $agg, 'add';
+ok $agg->add( 'tap1', $parser1 ), '... and calling it should succeed';
+ok $agg->add( 'tap2', $parser2 ), '... even if we add more than one parser';
+eval { $agg->add( 'tap1', $parser1 ) };
+like $@, qr/^You already have a parser for \Q(tap1)/,
+ '... but trying to reuse a description should be fatal';
+
+can_ok $agg, 'parsers';
+is scalar $agg->parsers, 2,
+ '... and it should report how many parsers it has';
+is_deeply [ $agg->parsers ], [ $parser1, $parser2 ],
+ '... or which parsers it has';
+is_deeply $agg->parsers('tap2'), $parser2, '... or reporting a single parser';
+is_deeply [ $agg->parsers(qw(tap2 tap1)) ], [ $parser2, $parser1 ],
+ '... or a group';
+
+# test aggregate results
+
+can_ok $agg, 'passed';
+is $agg->passed, 10,
+ '... and we should have the correct number of passed tests';
+is_deeply [ $agg->passed ], [qw(tap1 tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'failed';
+is $agg->failed, 2,
+ '... and we should have the correct number of failed tests';
+is_deeply [ $agg->failed ], [qw(tap1 tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'todo';
+is $agg->todo, 4, '... and we should have the correct number of todo tests';
+is_deeply [ $agg->todo ], [qw(tap1 tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'skipped';
+is $agg->skipped, 1,
+ '... and we should have the correct number of skipped tests';
+is_deeply [ $agg->skipped ], [qw(tap1)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'parse_errors';
+is $agg->parse_errors, 0, '... and the correct number of parse errors';
+is_deeply [ $agg->parse_errors ], [],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'todo_passed';
+is $agg->todo_passed, 1,
+ '... and the correct number of unexpectedly succeeded tests';
+is_deeply [ $agg->todo_passed ], [qw(tap2)],
+ '... and be able to get their descriptions';
+
+can_ok $agg, 'total';
+is $agg->total, $agg->passed + $agg->failed,
+ '... and we should have the correct number of total tests';
+
+can_ok $agg, 'has_problems';
+ok $agg->has_problems, '... and it should report true if there are problems';
+
+can_ok $agg, 'has_errors';
+ok $agg->has_errors, '... and it should report true if there are errors';
+
+can_ok $agg, 'get_status';
+is $agg->get_status, 'FAIL', '... and it should tell us the tests failed';
+
+can_ok $agg, 'all_passed';
+ok !$agg->all_passed, '... and it should tell us not all tests passed';
+
+# coverage testing
+
+# _get_parsers
+# bad descriptions
+# currently the $agg object has descriptions tap1 and tap2
+# call _get_parsers with another description.
+# $agg will call its _croak method
+my @die;
+
+eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $agg->_get_parsers('no_such_parser_for');
+};
+
+is @die, 1,
+ 'coverage tests for missing parsers... and we caught just one death message';
+like pop(@die),
+ qr/^A parser for \(no_such_parser_for\) could not be found at /,
+ '... and it was the expected death message';
+
+# _get_parsers in scalar context
+
+my $gp = $agg->_get_parsers(qw(tap1 tap2))
+ ; # should return ref to array containing parsers for tap1 and tap2
+
+is @$gp, 2,
+ 'coverage tests for _get_parser in scalar context... and we got the right number of parsers';
+isa_ok( $_, 'TAP::Parser' ) foreach (@$gp);
+
+# _get_parsers
+# todo_failed - this is a deprecated method, so it (and these tests)
+# can be removed eventually. However, it is showing up in the coverage
+# as never tested.
+my @warn;
+
+eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $agg->todo_failed();
+};
+
+# check the warning, making sure to capture the fullstops correctly (not
+# as "any char" matches)
+is @warn, 1,
+ 'coverage tests for deprecated todo_failed... and just one warning caught';
+like pop(@warn),
+ qr/^"todo_failed" is deprecated[.] Please use "todo_passed"[.] See the docs[.] at/,
+ '... and it was the expected warning';
+
+# has_problems
+# this has a large number of conditions 'OR'd together, so the tests get
+# a little complicated here
+
+# currently, we have covered the cases of failed() being true and none
+# of the summary methods failing
+
+# we need to set up test cases for
+# 1. !failed && todo_passed
+# 2. !failed && !todo_passed && parse_errors
+# 3. !failed && !todo_passed && !parse_errors && exit
+# 4. !failed && !todo_passed && !parse_errors && !exit && wait
+
+# note there is nothing wrong per se with the has_problems logic, these
+# are simply coverage tests
+
+# 1. !failed && todo_passed
+
+$agg = TAP::Parser::Aggregator->new();
+isa_ok $agg, 'TAP::Parser::Aggregator';
+
+$tap = <<'END_TAP';
+1..1
+ok 1 - you shall not pass! # TODO should have failed
+END_TAP
+
+my $parser3 = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser3, 'TAP::Parser';
+$parser3->run;
+
+$agg->add( 'tap3', $parser3 );
+
+is $agg->passed, 1,
+ 'coverage tests for !failed && todo_passed... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 1,
+ '... and the correct number of unexpectedly succeeded tests';
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
+is $agg->get_status, 'PASS',
+ '... and the status should be passing';
+ok !$agg->has_errors,
+ '.... but it should not report any errors';
+ok $agg->all_passed,
+ '... bonus tests should be passing tests, too';
+
+# 2. !failed && !todo_passed && parse_errors
+
+$agg = TAP::Parser::Aggregator->new();
+
+$tap = <<'END_TAP';
+1..-1
+END_TAP
+
+my $parser4 = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser4, 'TAP::Parser';
+$parser4->run;
+
+$agg->add( 'tap4', $parser4 );
+
+is $agg->passed, 0,
+ 'coverage tests for !failed && !todo_passed && parse_errors... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 0,
+ '... and the correct number of unexpectedly succeeded tests';
+is $agg->parse_errors, 1, '... and the correct number of parse errors';
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
+
+# 3. !failed && !todo_passed && !parse_errors && exit
+# now this is a little harder to emulate cleanly through creating tap
+# fragments and parsing, as exit and wait collect OS-status codes.
+# so we'll get a little funky with $agg and push exit and wait descriptions
+# in it - not very friendly to internal rep changes.
+
+$agg = TAP::Parser::Aggregator->new();
+
+$tap = <<'END_TAP';
+1..1
+ok 1 - you shall not pass!
+END_TAP
+
+my $parser5 = TAP::Parser->new( { tap => $tap } );
+$parser5->run;
+
+$agg->add( 'tap', $parser5 );
+
+push @{ $agg->{descriptions_for_exit} }, 'one possible reason';
+$agg->{exit}++;
+
+is $agg->passed, 1,
+ 'coverage tests for !failed && !todo_passed && !parse_errors... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 0,
+ '... and the correct number of unexpectedly succeeded tests';
+is $agg->parse_errors, 0, '... and the correct number of parse errors';
+
+my @exits = $agg->exit;
+
+is @exits, 1, '... and the correct number of exits';
+is pop(@exits), 'one possible reason',
+ '... and we collected the right exit reason';
+
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
+
+# 4. !failed && !todo_passed && !parse_errors && !exit && wait
+
+$agg = TAP::Parser::Aggregator->new();
+
+$agg->add( 'tap', $parser5 );
+
+push @{ $agg->{descriptions_for_wait} }, 'another possible reason';
+$agg->{wait}++;
+
+is $agg->passed, 1,
+ 'coverage tests for !failed && !todo_passed && !parse_errors && !exit... and we should have the correct number of passed tests';
+is $agg->failed, 0,
+ '... and we should have the correct number of failed tests';
+is $agg->todo_passed, 0,
+ '... and the correct number of unexpectedly succeeded tests';
+is $agg->parse_errors, 0, '... and the correct number of parse errors';
+is $agg->exit, 0, '... and the correct number of exits';
+
+my @waits = $agg->wait;
+
+is @waits, 1, '... and the correct number of waits';
+is pop(@waits), 'another possible reason',
+ '... and we collected the right wait reason';
+
+ok $agg->has_problems,
+ '... and it should report true that there are problems';
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 33;
+
+use TAP::Parser;
+
+my $tap = <<'END_TAP';
+1..4
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+Bail out! We ran out of foobar.
+END_TAP
+my $parser = TAP::Parser->new( { tap => $tap } );
+isa_ok $parser, 'TAP::Parser',
+ '... we should be able to parse bailed out tests';
+
+my @results;
+while ( my $result = $parser->next ) {
+ push @results => $result;
+}
+
+can_ok $parser, 'passed';
+is $parser->passed, 3,
+ '... and we shold have the correct number of passed tests';
+is_deeply [ $parser->passed ], [ 1, 2, 3 ],
+ '... and get a list of the passed tests';
+
+can_ok $parser, 'failed';
+is $parser->failed, 1, '... and the correct number of failed tests';
+is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests';
+
+can_ok $parser, 'actual_passed';
+is $parser->actual_passed, 2,
+ '... and we shold have the correct number of actually passed tests';
+is_deeply [ $parser->actual_passed ], [ 1, 3 ],
+ '... and get a list of the actually passed tests';
+
+can_ok $parser, 'actual_failed';
+is $parser->actual_failed, 2,
+ '... and the correct number of actually failed tests';
+is_deeply [ $parser->actual_failed ], [ 2, 4 ],
+ '... or get a list of the actually failed tests';
+
+can_ok $parser, 'todo';
+is $parser->todo, 1,
+ '... and we should have the correct number of TODO tests';
+is_deeply [ $parser->todo ], [2], '... and get a list of the TODO tests';
+
+ok !$parser->skipped,
+ '... and we should have the correct number of skipped tests';
+
+# check the plan
+
+can_ok $parser, 'plan';
+is $parser->plan, '1..4', '... and we should have the correct plan';
+is $parser->tests_planned, 4, '... and the correct number of tests';
+
+# results() is sane?
+
+ok @results, 'The parser should return results';
+is scalar @results, 8, '... and there should be one for each line';
+
+# check the test plan
+
+my $result = shift @results;
+ok $result->is_plan, 'We should have a plan';
+
+# a normal, passing test
+
+my $test = shift @results;
+ok $test->is_test, '... and a test';
+
+# junk lines should be preserved
+
+my $unknown = shift @results;
+ok $unknown->is_unknown, '... and an unknown line';
+
+# a failing test, which also happens to have a directive
+
+my $failed = shift @results;
+ok $failed->is_test, '... and another test';
+
+# comments
+
+my $comment = shift @results;
+ok $comment->is_comment, '... and a comment';
+
+# another normal, passing test
+
+$test = shift @results;
+ok $test->is_test, '... and another test';
+
+# a failing test
+
+$failed = shift @results;
+ok $failed->is_test, '... and yet another test';
+
+# ok 5 # skip we have no description
+# skipped test
+my $bailout = shift @results;
+ok $bailout->is_bailout, 'And finally we should have a bailout';
+is $bailout->as_string, 'We ran out of foobar.',
+ '... and as_string() should return the explanation';
+is $bailout->raw, 'Bail out! We ran out of foobar.',
+ '... and raw() should return the explanation';
+is $bailout->explanation, 'We ran out of foobar.',
+ '... and it should have the correct explanation';
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- chdir 't';
- @INC = '../lib';
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 38;
+
+use TAP::Base;
+
+{
+
+ # No callbacks allowed
+ can_ok 'TAP::Base', 'new';
+ my $base = TAP::Base->new();
+ isa_ok $base, 'TAP::Base', 'object of correct type';
+ foreach my $method (qw(callback _croak _callback_for _initialize)) {
+ can_ok $base, $method;
}
+
+ eval {
+ $base->callback(
+ some_event => sub {
+
+ # do nothing
+ }
+ );
+ };
+ like( $@, qr/No callbacks/, 'no callbacks allowed croaks OK' );
+ my $cb = $base->_callback_for('some_event');
+ ok( !$cb, 'no callback installed' );
+}
+
+{
+
+ # No callbacks allowed, constructor should croak
+ eval {
+ my $base = TAP::Base->new(
+ { callbacks => {
+ some_event => sub {
+
+ # do nothing
+ }
+ }
+ }
+ );
+ };
+ like(
+ $@, qr/No callbacks/,
+ 'no callbacks in constructor croaks OK'
+ );
}
+package CallbackOK;
+
+use TAP::Base;
+use vars qw(@ISA);
+@ISA = 'TAP::Base';
+
+sub _initialize {
+ my $self = shift;
+ my $args = shift;
+ $self->SUPER::_initialize( $args, [qw( nice_event other_event )] );
+ return $self;
+}
+
+package main;
+{
+ my $base = CallbackOK->new();
+ isa_ok $base, 'TAP::Base';
+
+ eval {
+ $base->callback(
+ some_event => sub {
+
+ # do nothing
+ }
+ );
+ };
+ like( $@, qr/Callback some_event/, 'illegal callback croaks OK' );
+
+ my ( $nice, $other ) = ( 0, 0 );
+
+ eval {
+ $base->callback( other_event => sub { $other-- } );
+ $base->callback( nice_event => sub { $nice++; return shift() . 'OK' }
+ );
+ };
+
+ ok( !$@, 'callbacks installed OK' );
+
+ my $nice_cbs = $base->_callback_for('nice_event');
+ is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$nice_cbs, 1, 'right number of callbacks' );
+ my $nice_cb = $nice_cbs->[0];
+ ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
+ my $got = $nice_cb->('Is ');
+ is( $got, 'Is OK', 'args passed to callback' );
+ cmp_ok( $nice, '==', 1, 'callback calls the right sub' );
+
+ my $other_cbs = $base->_callback_for('other_event');
+ is( ref $other_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$other_cbs, 1, 'right number of callbacks' );
+ my $other_cb = $other_cbs->[0];
+ ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
+ $other_cb->();
+ cmp_ok( $other, '==', -1, 'callback calls the right sub' );
+
+ my @got = $base->_make_callback( 'nice_event', 'I am ' );
+ is( scalar @got, 1, 'right number of results' );
+ is( $got[0], 'I am OK', 'callback via _make_callback works' );
+}
+
+{
+ my ( $nice, $other ) = ( 0, 0 );
+
+ my $base = CallbackOK->new(
+ { callbacks => {
+ nice_event => sub { $nice++ }
+ }
+ }
+ );
+
+ isa_ok $base, 'TAP::Base', 'object creation with callback succeeds';
+
+ eval {
+ $base->callback(
+ some_event => sub {
+
+ # do nothing
+ }
+ );
+ };
+ like( $@, qr/Callback some_event/, 'illegal callback croaks OK' );
+
+ eval {
+ $base->callback( other_event => sub { $other-- } );
+ };
+
+ ok( !$@, 'callback installed OK' );
+
+ my $nice_cbs = $base->_callback_for('nice_event');
+ is( ref $nice_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$nice_cbs, 1, 'right number of callbacks' );
+ my $nice_cb = $nice_cbs->[0];
+ ok( ref $nice_cb eq 'CODE', 'callback for nice_event returned' );
+ $nice_cb->();
+ cmp_ok( $nice, '==', 1, 'callback calls the right sub' );
+
+ my $other_cbs = $base->_callback_for('other_event');
+ is( ref $other_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$other_cbs, 1, 'right number of callbacks' );
+ my $other_cb = $other_cbs->[0];
+ ok( ref $other_cb eq 'CODE', 'callback for other_event returned' );
+ $other_cb->();
+ cmp_ok( $other, '==', -1, 'callback calls the right sub' );
+
+ # my @got = $base->_make_callback( 'nice_event', 'I am ' );
+ # is ( scalar @got, 1, 'right number of results' );
+ # is( $got[0], 'I am OK', 'callback via _make_callback works' );
+
+ my $status = undef;
-print "1..1\n";
+ # Stack another callback
+ $base->callback( other_event => sub { $status = 'OK'; return 'Aye' } );
-unless (eval 'require Test::Harness') {
- print "not ok 1\n";
-} else {
- print "ok 1\n";
+ my $new_cbs = $base->_callback_for('other_event');
+ is( ref $new_cbs, 'ARRAY', 'callbacks type ok' );
+ is( scalar @$new_cbs, 2, 'right number of callbacks' );
+ my $new_cb = $new_cbs->[1];
+ ok( ref $new_cb eq 'CODE', 'callback for new_event returned' );
+ my @got = $new_cb->();
+ is( $status, 'OK', 'new callback called OK' );
}
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 10;
+
+use TAP::Parser;
+use TAP::Parser::Iterator;
+
+my $tap = <<'END_TAP';
+1..5
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+END_TAP
+
+my @tests;
+my $plan_output;
+my $todo = 0;
+my $skip = 0;
+my %callbacks = (
+ test => sub {
+ my $test = shift;
+ push @tests => $test;
+ $todo++ if $test->has_todo;
+ $skip++ if $test->has_skip;
+ },
+ plan => sub {
+ my $plan = shift;
+ $plan_output = $plan->as_string;
+ }
+);
+
+my $stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+my $parser = TAP::Parser->new(
+ { stream => $stream,
+ callbacks => \%callbacks,
+ }
+);
+
+can_ok $parser, 'run';
+$parser->run;
+is $plan_output, '1..5', 'Plan callbacks should succeed';
+is scalar @tests, $parser->tests_run, '... as should the test callbacks';
+
+@tests = ();
+$plan_output = '';
+$todo = 0;
+$skip = 0;
+my $else = 0;
+my $all = 0;
+my $end = 0;
+%callbacks = (
+ test => sub {
+ my $test = shift;
+ push @tests => $test;
+ $todo++ if $test->has_todo;
+ $skip++ if $test->has_skip;
+ },
+ plan => sub {
+ my $plan = shift;
+ $plan_output = $plan->as_string;
+ },
+ EOF => sub {
+ $end = 1 if $all == 8;
+ },
+ ELSE => sub {
+ $else++;
+ },
+ ALL => sub {
+ $all++;
+ },
+);
+
+$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+$parser = TAP::Parser->new(
+ { stream => $stream,
+ callbacks => \%callbacks,
+ }
+);
+
+can_ok $parser, 'run';
+$parser->run;
+is $plan_output, '1..5', 'Plan callbacks should succeed';
+is scalar @tests, $parser->tests_run, '... as should the test callbacks';
+is $else, 2, '... and the correct number of "ELSE" lines should be seen';
+is $all, 8, '... and the correct total number of lines should be seen';
+is $end, 1, 'EOF callback correctly called';
+
+# Check callback name policing
+
+%callbacks = (
+ sometest => sub { },
+ plan => sub { },
+ random => sub { },
+ ALL => sub { },
+ ELSES => sub { },
+);
+
+$stream = TAP::Parser::Iterator->new( [ split /\n/ => $tap ] );
+eval {
+ $parser = TAP::Parser->new(
+ { stream => $stream,
+ callbacks => \%callbacks,
+ }
+ );
+};
+
+like $@, qr/Callback/, 'Bad callback keys faulted';
--- /dev/null
+#!/usr/bin/perl -w
+
+# Test that env vars are honoured.
+
+use strict;
+use lib 't/lib';
+
+use Test::More (
+ $^O eq 'VMS'
+ ? ( skip_all => 'VMS' )
+ : ( tests => 1 )
+);
+
+use Test::Harness;
+
+# HARNESS_PERL_SWITCHES
+
+my $test_template = <<'END';
+#!/usr/bin/perl
+
+use Test::More tests => 1;
+
+is $ENV{HARNESS_PERL_SWITCHES}, '-w';
+END
+
+open TEST, ">env_check_t.tmp";
+print TEST $test_template;
+close TEST;
+
+END { unlink 'env_check_t.tmp'; }
+
+{
+ local $ENV{HARNESS_PERL_SWITCHES} = '-w';
+ my ( $tot, $failed )
+ = Test::Harness::execute_tests( tests => ['env_check_t.tmp'] );
+ is $tot->{bad}, 0;
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 5;
+
+use File::Spec;
+use Test::Harness;
+
+{
+
+ #todo_skip 'Harness compatibility incomplete', 5;
+ #local $TODO = 'Harness compatibility incomplete';
+ my $died;
+
+ sub prepare_for_death {
+ $died = 0;
+ return sub { $died = 1 }
+ }
+
+ my $curdir = File::Spec->curdir;
+ my $sample_tests
+ = $ENV{PERL_CORE}
+ ? File::Spec->catdir( $curdir, 'lib', 'sample-tests' )
+ : File::Spec->catdir( $curdir, 't', 'sample-tests' );
+
+ {
+ local $SIG{__DIE__} = prepare_for_death();
+ eval { _runtests( File::Spec->catfile( $sample_tests, "simple" ) ); };
+ ok( !$@, "simple lives" );
+ is( $died, 0, "Death never happened" );
+ }
+
+ {
+ local $SIG{__DIE__} = prepare_for_death();
+ eval {
+ _runtests( File::Spec->catfile( $sample_tests, "too_many" ) );
+ };
+ ok( $@, "error OK" );
+ ok( $@ =~ m[Failed 1/1], "too_many dies" );
+ is( $died, 1, "Death happened" );
+ }
+}
+
+sub _runtests {
+ my (@tests) = @_;
+
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ local $ENV{HARNESS_VERBOSE} = 0;
+ local $ENV{HARNESS_DEBUG} = 0;
+ local $ENV{HARNESS_TIMER} = 0;
+
+ local $Test::Harness::Verbose = -9;
+
+ runtests(@tests);
+}
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+#!/usr/bin/perl -w
+
+# Test that @INC is propogated from the harness process to the test
+# process.
+
+use strict;
+use lib 't/lib';
+
+sub has_crazy_patch {
+ my $sentinel = 'blirpzoffle';
+ local $ENV{PERL5LIB} = $sentinel;
+ my $command = join ' ',
+ map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' );
+ my $path = `$command`;
+ my @got = ( $path =~ /($sentinel)/g );
+ return @got > 1;
+}
+
+use Test::More (
+ $^O eq 'VMS' ? ( skip_all => 'VMS' )
+ : has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' )
+ : ( tests => 2 )
+);
+
+use Data::Dumper;
+use Test::Harness;
+
+# Change @INC so we ensure it's preserved.
+use lib 'wibble';
+
+# TODO: Disabled until we find out why it's breaking on Windows. It's
+# not strictly a TODO because it seems pretty likely that it's a Windows
+# problem rather than a problem with Test::Harness.
+
+# Put a stock directory near the beginning.
+# use lib $INC[$#INC-2];
+
+my $inc = Data::Dumper->new( [ \@INC ] )->Terse(1)->Purity(1)->Dump;
+my $taint_inc
+ = Data::Dumper->new( [ [ grep { $_ ne '.' } @INC ] ] )->Terse(1)->Purity(1)
+ ->Dump;
+
+my $test_template = <<'END';
+#!/usr/bin/perl %s
+
+use Test::More tests => 2;
+
+sub _strip_dups {
+ my %%dups;
+ # Drop '.' which sneaks in on some platforms
+ return grep { $_ ne '.' } grep { !$dups{$_}++ } @_;
+}
+
+# Make sure we did something sensible with PERL5LIB
+like $ENV{PERL5LIB}, qr{wibble};
+
+is_deeply(
+ [_strip_dups(@INC)],
+ [_strip_dups(@{%s})],
+ '@INC propagated to test'
+) or do {
+ diag join ",\n", _strip_dups(@INC);
+ diag '-----------------';
+ diag join ",\n", _strip_dups(@{%s});
+};
+END
+
+open TEST, ">inc_check.t.tmp";
+printf TEST $test_template, '', $inc, $inc;
+close TEST;
+
+open TEST, ">inc_check_taint.t.tmp";
+printf TEST $test_template, '-T', $taint_inc, $taint_inc;
+close TEST;
+END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; }
+
+for my $test ( 'inc_check_taint.t.tmp', 'inc_check.t.tmp' ) {
+ my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$test] );
+ is $tot->{bad}, 0;
+}
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use strict;
+
+use Test::More tests => 1;
+
+use Dev::Null;
+
+use Test::Harness;
+
+sub _all_ok {
+ my ($tot) = shift;
+ return $tot->{bad} == 0
+ && ( $tot->{max} || $tot->{skipped} ) ? 1 : 0;
+}
+
+{
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ local $Test::Harness::Verbose = -9;
+
+ push @INC, 'examples';
+
+ tie *NULL, 'Dev::Null' or die $!;
+ select NULL;
+ my ( $tot, $failed ) = Test::Harness::execute_tests(
+ tests => [
+ $ENV{PERL_CORE}
+ ? 'lib/sample-tests/inc_taint'
+ : 't/sample-tests/inc_taint'
+ ]
+ );
+ select STDOUT;
+
+ ok( _all_ok($tot), 'tests with taint on preserve @INC' );
+}
--- /dev/null
+if ( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) {
+ print "1..0 # Skip: t/TEST needs numbers\n";
+ exit;
+}
+
+print <<END;
+1..6
+ok
+ok
+ok
+ok
+ok
+ok
+END
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 1;
+use Test::Harness;
+
+{
+ #28567
+ unshift @INC, 'wibble';
+ my @before = Test::Harness::_filtered_inc();
+ unshift @INC, sub {die};
+ my @after = Test::Harness::_filtered_inc();
+ is_deeply \@after, \@before, 'subref removed from @INC';
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip until we figure out why it exists with no output just after the plan\n";
+ exit 0;
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+
+use File::Spec;
+
+use Test::Harness qw(execute_tests);
+
+# unset this global when self-testing ('testcover' and etc issue)
+local $ENV{HARNESS_PERL_SWITCHES};
+
+{
+
+ # if the harness wants to save the resulting TAP we shouldn't
+ # do it for our internal calls
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+
+ my $TEST_DIR = 't/sample-tests';
+ my $PER_LOOP = 4;
+
+ my $results = {
+ 'descriptive' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ join(
+ ',', qw(
+ descriptive die die_head_end die_last_minute duplicates
+ head_end head_fail inc_taint junk_before_plan lone_not_bug
+ no_nums no_output schwern sequence_misparse shbang_misparse
+ simple simple_fail skip skip_nomsg skipall skipall_nomsg
+ stdout_stderr switches taint todo_inline
+ todo_misparse too_many vms_nit
+ )
+ ) => {
+ 'failed' => {
+ 't/sample-tests/die' => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => 't/sample-tests/die',
+ 'wstat' => '256'
+ },
+ 't/sample-tests/die_head_end' => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => 't/sample-tests/die_head_end',
+ 'wstat' => '256'
+ },
+ 't/sample-tests/die_last_minute' => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => 0,
+ 'max' => 4,
+ 'name' => 't/sample-tests/die_last_minute',
+ 'wstat' => '256'
+ },
+ 't/sample-tests/duplicates' => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => 10,
+ 'name' => 't/sample-tests/duplicates',
+ 'wstat' => ''
+ },
+ 't/sample-tests/head_fail' => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 4,
+ 'name' => 't/sample-tests/head_fail',
+ 'wstat' => ''
+ },
+ 't/sample-tests/inc_taint' => {
+ 'canon' => 1,
+ 'estat' => 1,
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => 't/sample-tests/inc_taint',
+ 'wstat' => '256'
+ },
+ 't/sample-tests/no_nums' => {
+ 'canon' => 3,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 5,
+ 'name' => 't/sample-tests/no_nums',
+ 'wstat' => ''
+ },
+ 't/sample-tests/no_output' => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => 't/sample-tests/no_output',
+ 'wstat' => ''
+ },
+ 't/sample-tests/simple_fail' => {
+ 'canon' => '2 5',
+ 'estat' => '',
+ 'failed' => 2,
+ 'max' => 5,
+ 'name' => 't/sample-tests/simple_fail',
+ 'wstat' => ''
+ },
+ 't/sample-tests/switches' => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => 't/sample-tests/switches',
+ 'wstat' => ''
+ },
+ 't/sample-tests/todo_misparse' => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => 't/sample-tests/todo_misparse',
+ 'wstat' => ''
+ },
+ 't/sample-tests/too_many' => {
+ 'canon' => '4-7',
+ 'estat' => 4,
+ 'failed' => 4,
+ 'max' => 3,
+ 'name' => 't/sample-tests/too_many',
+ 'wstat' => '1024'
+ },
+ 't/sample-tests/vms_nit' => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => 't/sample-tests/vms_nit',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {
+ 't/sample-tests/todo_inline' => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => 't/sample-tests/todo_inline',
+ 'wstat' => ''
+ }
+ },
+ 'totals' => {
+ 'bad' => 13,
+ 'bonus' => 1,
+ 'files' => 28,
+ 'good' => 15,
+ 'max' => 77,
+ 'ok' => 78,
+ 'skipped' => 2,
+ 'sub_skipped' => 2,
+ 'tests' => 28,
+ 'todo' => 2
+ }
+ },
+ 'die' => {
+ 'failed' => {
+ 't/sample-tests/die' => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => 't/sample-tests/die',
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'die_head_end' => {
+ 'failed' => {
+ 't/sample-tests/die_head_end' => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => 't/sample-tests/die_head_end',
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 0,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'die_last_minute' => {
+ 'failed' => {
+ 't/sample-tests/die_last_minute' => {
+ 'canon' => '??',
+ 'estat' => 1,
+ 'failed' => 0,
+ 'max' => 4,
+ 'name' => 't/sample-tests/die_last_minute',
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'duplicates' => {
+ 'failed' => {
+ 't/sample-tests/duplicates' => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => 10,
+ 'name' => 't/sample-tests/duplicates',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 10,
+ 'ok' => 11,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'head_end' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'head_fail' => {
+ 'failed' => {
+ 't/sample-tests/head_fail' => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 4,
+ 'name' => 't/sample-tests/head_fail',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 4,
+ 'ok' => 3,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'inc_taint' => {
+ 'failed' => {
+ 't/sample-tests/inc_taint' => {
+ 'canon' => 1,
+ 'estat' => 1,
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => 't/sample-tests/inc_taint',
+ 'wstat' => '256'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 1,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'junk_before_plan' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'lone_not_bug' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'no_nums' => {
+ 'failed' => {
+ 't/sample-tests/no_nums' => {
+ 'canon' => 3,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 5,
+ 'name' => 't/sample-tests/no_nums',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 5,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'no_output' => {
+ 'failed' => {
+ 't/sample-tests/no_output' => {
+ 'canon' => '??',
+ 'estat' => '',
+ 'failed' => '??',
+ 'max' => '??',
+ 'name' => 't/sample-tests/no_output',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'schwern' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'sequence_misparse' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'shbang_misparse' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 2,
+ 'ok' => 2,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'simple' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'simple_fail' => {
+ 'failed' => {
+ 't/sample-tests/simple_fail' => {
+ 'canon' => '2 5',
+ 'estat' => '',
+ 'failed' => 2,
+ 'max' => 5,
+ 'name' => 't/sample-tests/simple_fail',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 5,
+ 'ok' => 3,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skip' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 5,
+ 'ok' => 5,
+ 'skipped' => 0,
+ 'sub_skipped' => 1,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skip_nomsg' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 1,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skipall' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 1,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'skipall_nomsg' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 0,
+ 'ok' => 0,
+ 'skipped' => 1,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'stdout_stderr' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 4,
+ 'ok' => 4,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'switches' => {
+ 'failed' => {
+ 't/sample-tests/switches' => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => 't/sample-tests/switches',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 1,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'taint' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'taint_warn' => {
+ 'failed' => {},
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 1,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ },
+ 'require' => 5.008001,
+ },
+ 'todo_inline' => {
+ 'failed' => {},
+ 'todo' => {
+ 't/sample-tests/todo_inline' => {
+ 'canon' => 2,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => 't/sample-tests/todo_inline',
+ 'wstat' => ''
+ }
+ },
+ 'totals' => {
+ 'bad' => 0,
+ 'bonus' => 1,
+ 'files' => 1,
+ 'good' => 1,
+ 'max' => 3,
+ 'ok' => 3,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 2
+ }
+ },
+ 'todo_misparse' => {
+ 'failed' => {
+ 't/sample-tests/todo_misparse' => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 1,
+ 'name' => 't/sample-tests/todo_misparse',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 1,
+ 'ok' => 0,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'too_many' => {
+ 'failed' => {
+ 't/sample-tests/too_many' => {
+ 'canon' => '4-7',
+ 'estat' => 4,
+ 'failed' => 4,
+ 'max' => 3,
+ 'name' => 't/sample-tests/too_many',
+ 'wstat' => '1024'
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 3,
+ 'ok' => 7,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ },
+ 'vms_nit' => {
+ 'failed' => {
+ 't/sample-tests/vms_nit' => {
+ 'canon' => 1,
+ 'estat' => '',
+ 'failed' => 1,
+ 'max' => 2,
+ 'name' => 't/sample-tests/vms_nit',
+ 'wstat' => ''
+ }
+ },
+ 'todo' => {},
+ 'totals' => {
+ 'bad' => 1,
+ 'bonus' => 0,
+ 'files' => 1,
+ 'good' => 0,
+ 'max' => 2,
+ 'ok' => 1,
+ 'skipped' => 0,
+ 'sub_skipped' => 0,
+ 'tests' => 1,
+ 'todo' => 0
+ }
+ }
+ };
+
+ my $num_tests = ( keys %$results ) * $PER_LOOP;
+
+ plan tests => $num_tests;
+
+ sub local_name {
+ my $name = shift;
+ return File::Spec->catfile( split /\//, $name );
+ }
+
+ sub local_result {
+ my $hash = shift;
+ my $new = {};
+
+ while ( my ( $file, $want ) = each %$hash ) {
+ if ( exists $want->{name} ) {
+ $want->{name} = local_name( $want->{name} );
+ }
+ $new->{ local_name($file) } = $want;
+ }
+ return $new;
+ }
+
+ sub vague_status {
+ my $hash = shift;
+ return $hash unless $^O eq 'VMS';
+
+ while ( my ( $file, $want ) = each %$hash ) {
+ for ( qw( estat wstat ) ) {
+ if ( exists $want->{$_} ) {
+ $want->{$_} = $want->{$_} ? 1 : 0;
+ }
+ }
+ }
+ return $hash
+ }
+
+ {
+ local $^W = 0;
+
+ # Silence harness output
+ *TAP::Formatter::Console::_output = sub {
+
+ # do nothing
+ };
+ }
+
+ for my $test_key ( sort keys %$results ) {
+ my $result = $results->{$test_key};
+ SKIP: {
+ if ( $result->{require} && $] < $result->{require} ) {
+ skip "Test requires Perl $result->{require}, we have $]", 4;
+ }
+ my @test_names = split( /,/, $test_key );
+ my @test_files
+ = map { File::Spec->catfile( $TEST_DIR, $_ ) } @test_names;
+
+ # For now we supress STDERR because it crufts up /our/ test
+ # results. Should probably capture and analyse it.
+ local ( *OLDERR, *OLDOUT );
+ open OLDERR, '>&STDERR' or die $!;
+ open OLDOUT, '>&STDOUT' or die $!;
+ my $devnull = File::Spec->devnull;
+ open STDERR, ">$devnull" or die $!;
+ open STDOUT, ">$devnull" or die $!;
+
+ my ( $tot, $fail, $todo, $harness, $aggregate )
+ = execute_tests( tests => \@test_files );
+
+ open STDERR, '>&OLDERR' or die $!;
+ open STDOUT, '>&OLDOUT' or die $!;
+
+ my $bench = delete $tot->{bench};
+ isa_ok $bench, 'Benchmark';
+
+ # Localise filenames in failed, todo
+ my $lfailed = vague_status( local_result( $result->{failed} ) );
+ my $ltodo = vague_status( local_result( $result->{todo} ) );
+
+ # use Data::Dumper;
+ # diag Dumper( [ $lfailed, $ltodo ] );
+
+ is_deeply $tot, $result->{totals}, "totals match for $test_key";
+ is_deeply vague_status($fail), $lfailed,
+ "failure summary matches for $test_key";
+ is_deeply vague_status($todo), $ltodo,
+ "todo summary matches for $test_key";
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl -Tw
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 2;
+use Test::Harness;
+
+my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set";
+ok( $ver =~ /^[23].\d\d(_\d\d)?$/, "Version is proper format" );
+is( $ver, $Test::Harness::VERSION );
--- /dev/null
+use strict;
+use lib 't/lib';
+use Test::More;
+use TAP::Formatter::Console;
+
+my @schedule;
+
+BEGIN {
+ @schedule = (
+ { method => '_range',
+ in => sub {qw/2 7 1 3 10 9/},
+ out => sub {qw/1-3 7 9-10/},
+ name => '... and it should return numbers as ranges'
+ },
+ { method => '_balanced_range',
+ in => sub { 7, qw/2 7 1 3 10 9/ },
+ out => sub { '1-3, 7', '9-10' },
+ name => '... and it should return numbers as ranges'
+ },
+ );
+
+ plan tests => @schedule * 3;
+}
+
+for my $test (@schedule) {
+ my $name = $test->{name};
+ my $cons = TAP::Formatter::Console->new;
+ isa_ok $cons, 'TAP::Formatter::Console';
+ my $method = $test->{method};
+ can_ok $cons, $method;
+ is_deeply [ $cons->$method( $test->{in}->() ) ], [ $test->{out}->() ],
+ $name;
+}
+
+#### Color tests ####
+
+package Colorizer;
+
+sub new { bless {}, shift }
+sub can_color {1}
+
+sub set_color {
+ my ( $self, $output, $color ) = @_;
+ $output->("[[$color]]");
+}
+
+package main;
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 23;
+
+use TAP::Parser;
+
+my $plan_line = 'TAP::Parser::Result::Plan';
+my $test_line = 'TAP::Parser::Result::Test';
+
+sub _parser {
+ my $parser = TAP::Parser->new( { tap => shift } );
+ $parser->run;
+ return $parser;
+}
+
+# validate that plan!
+
+my $parser = _parser(<<'END_TAP');
+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
+# comments are allowed after an ending plan
+END_TAP
+
+can_ok $parser, 'parse_errors';
+ok !$parser->parse_errors,
+ '... comments should be allowed after a terminating plan';
+
+$parser = _parser(<<'END_TAP');
+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
+# yeah, yeah, I know.
+ok
+END_TAP
+
+can_ok $parser, 'parse_errors';
+is scalar $parser->parse_errors, 2, '... and we should have two parse errors';
+
+is [ $parser->parse_errors ]->[0],
+ 'Plan (1..3) must be at the beginning or end of the TAP output',
+ '... telling us that our plan was misplaced';
+is [ $parser->parse_errors ]->[1],
+ 'Bad plan. You planned 3 tests but ran 4.',
+ '... and telling us we ran the wrong number of tests.';
+
+$parser = _parser(<<'END_TAP');
+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
+# yo quiero tests!
+1..3
+END_TAP
+ok !$parser->parse_errors, '... but test plan-like data can be in a comment';
+
+$parser = _parser(<<'END_TAP');
+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..5
+# yo quiero tests!
+1..3
+END_TAP
+ok !$parser->parse_errors, '... or a description';
+
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo 1..4
+ok 3 - read the rest of the file
+# yo quiero tests!
+1..3
+END_TAP
+ok !$parser->parse_errors, '... or a directive';
+
+# test numbers included?
+
+$parser = _parser(<<'END_TAP');
+1..3
+ok 1 - input file opened
+not ok 2 - first line of the input valid # todo some data
+ok read the rest of the file
+# this is ...
+END_TAP
+eval { $parser->run };
+ok !$@, 'We can mix and match the presence of test numbers';
+
+$parser = _parser(<<'END_TAP');
+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
+END_TAP
+
+is + ( $parser->parse_errors )[0],
+ 'Tests out of sequence. Found (2) but expected (3)',
+ '... and if the numbers are there, they cannot be out of sequence';
+
+$parser = _parser(<<'END_TAP');
+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
+END_TAP
+
+is $parser->parse_errors, 2,
+ 'Having two errors in the TAP should result in two errors (duh)';
+my $expected = [
+ 'Tests out of sequence. Found (2) but expected (3)',
+ 'No plan found in TAP output'
+];
+is_deeply [ $parser->parse_errors ], $expected,
+ '... and they should be the correct errors';
+
+$parser = _parser(<<'END_TAP');
+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
+END_TAP
+
+is $parser->parse_errors, 1, 'Having no plan should cause an error';
+is + ( $parser->parse_errors )[0], 'No plan found in TAP output',
+ '... with a correct error message';
+
+$parser = _parser(<<'END_TAP');
+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
+END_TAP
+
+is $parser->parse_errors, 1,
+ 'Having more than one plan should cause an error';
+is + ( $parser->parse_errors )[0], 'More than one plan found in TAP output',
+ '... with a correct error message';
+
+can_ok $parser, 'is_good_plan';
+$parser = _parser(<<'END_TAP');
+1..2
+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
+END_TAP
+
+is $parser->parse_errors, 1,
+ 'Having the wrong number of planned tests is a parse error';
+is + ( $parser->parse_errors )[0],
+ 'Bad plan. You planned 2 tests but ran 3.',
+ '... with a correct error message';
+
+# XXX internals: plan will not set to true if defined
+$parser->is_good_plan(undef);
+$parser = _parser(<<'END_TAP');
+ok 1 - input file opened
+1..1
+END_TAP
+
+ok $parser->is_good_plan,
+ '... and it should return true if the plan is correct';
+
+# TAP::Parser coverage tests
+{
+
+ # good_plan coverage
+
+ my @warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $parser->good_plan;
+ };
+
+ is @warn, 1, 'coverage testing of good_plan';
+
+ like pop @warn,
+ qr/good_plan[(][)] is deprecated. Please use "is_good_plan[(][)]"/,
+ '...and it fell-back like we expected';
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 81;
+
+use TAP::Parser::Grammar;
+use TAP::Parser::Iterator::Array;
+
+my $GRAMMAR = 'TAP::Parser::Grammar';
+
+# Array based stream that we can push items in to
+package SS;
+
+sub new {
+ my $class = shift;
+ return bless [], $class;
+}
+
+sub next {
+ my $self = shift;
+ return shift @$self;
+}
+
+sub put {
+ my $self = shift;
+ unshift @$self, @_;
+}
+
+sub handle_unicode { }
+
+package main;
+
+my $stream = SS->new;
+can_ok $GRAMMAR, 'new';
+my $grammar = $GRAMMAR->new($stream);
+isa_ok $grammar, $GRAMMAR, '... and the object it returns';
+
+# Note: all methods are actually class methods. See the docs for the reason
+# why. We'll still use the instance because that should be forward
+# compatible.
+
+my @V12 = qw(bailout comment plan simple_test test version);
+my @V13 = ( @V12, 'yaml' );
+
+can_ok $grammar, 'token_types';
+ok my @types = sort( $grammar->token_types ),
+ '... and calling it should succeed (v12)';
+is_deeply \@types, \@V12, '... and return the correct token types (v12)';
+
+$grammar->set_version(13);
+ok @types = sort( $grammar->token_types ),
+ '... and calling it should succeed (v13)';
+is_deeply \@types, \@V13, '... and return the correct token types (v13)';
+
+can_ok $grammar, 'syntax_for';
+can_ok $grammar, 'handler_for';
+
+my ( %syntax_for, %handler_for );
+foreach my $type (@types) {
+ ok $syntax_for{$type} = $grammar->syntax_for($type),
+ '... and calling syntax_for() with a type name should succeed';
+ cmp_ok ref $syntax_for{$type}, 'eq', 'Regexp',
+ '... and it should return a regex';
+
+ ok $handler_for{$type} = $grammar->handler_for($type),
+ '... and calling handler_for() with a type name should succeed';
+ cmp_ok ref $handler_for{$type}, 'eq', 'CODE',
+ '... and it should return a code reference';
+}
+
+# Test the plan. Gotta have a plan.
+my $plan = '1..1';
+like $plan, $syntax_for{'plan'}, 'A basic plan should match its syntax';
+
+my $method = $handler_for{'plan'};
+$plan =~ $syntax_for{'plan'};
+ok my $plan_token = $grammar->$method($plan),
+ '... and the handler should return a token';
+
+my $expected = {
+ 'explanation' => '',
+ 'directive' => '',
+ 'type' => 'plan',
+ 'tests_planned' => 1,
+ 'raw' => '1..1',
+ 'todo_list' => [],
+};
+is_deeply $plan_token, $expected,
+ '... and it should contain the correct data';
+
+can_ok $grammar, 'tokenize';
+$stream->put($plan);
+ok my $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# a plan with a skip directive
+
+$plan = '1..0 # SKIP why not?';
+like $plan, $syntax_for{'plan'}, 'a basic plan should match its syntax';
+
+$plan =~ $syntax_for{'plan'};
+ok $plan_token = $grammar->$method($plan),
+ '... and the handler should return a token';
+
+$expected = {
+ 'explanation' => 'why not?',
+ 'directive' => 'SKIP',
+ 'type' => 'plan',
+ 'tests_planned' => 0,
+ 'raw' => '1..0 # SKIP why not?',
+ 'todo_list' => [],
+};
+is_deeply $plan_token, $expected,
+ '... and it should contain the correct data';
+
+$stream->put($plan);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# implied skip
+
+$plan = '1..0';
+like $plan, $syntax_for{'plan'},
+ 'A plan with an implied "skip all" should match its syntax';
+
+$plan =~ $syntax_for{'plan'};
+ok $plan_token = $grammar->$method($plan),
+ '... and the handler should return a token';
+
+$expected = {
+ 'explanation' => '',
+ 'directive' => 'SKIP',
+ 'type' => 'plan',
+ 'tests_planned' => 0,
+ 'raw' => '1..0',
+ 'todo_list' => [],
+};
+is_deeply $plan_token, $expected,
+ '... and it should contain the correct data';
+
+$stream->put($plan);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# bad plan
+
+$plan = '1..0 # TODO 3,4,5'; # old syntax. No longer supported
+unlike $plan, $syntax_for{'plan'},
+ 'Bad plans should not match the plan syntax';
+
+# Bail out!
+
+my $bailout = 'Bail out!';
+like $bailout, $syntax_for{'bailout'},
+ 'Bail out! should match a bailout syntax';
+
+$stream->put($bailout);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+$expected = {
+ 'bailout' => '',
+ 'type' => 'bailout',
+ 'raw' => 'Bail out!'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+$bailout = 'Bail out! some explanation';
+like $bailout, $syntax_for{'bailout'},
+ 'Bail out! should match a bailout syntax';
+
+$stream->put($bailout);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+$expected = {
+ 'bailout' => 'some explanation',
+ 'type' => 'bailout',
+ 'raw' => 'Bail out! some explanation'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# test comment
+
+my $comment = '# this is a comment';
+like $comment, $syntax_for{'comment'},
+ 'Comments should match the comment syntax';
+
+$stream->put($comment);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+$expected = {
+ 'comment' => 'this is a comment',
+ 'type' => 'comment',
+ 'raw' => '# this is a comment'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# test tests :/
+
+my $test = 'ok 1 this is a test';
+like $test, $syntax_for{'test'}, 'Tests should match the test syntax';
+
+$stream->put($test);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'ok' => 'ok',
+ 'explanation' => '',
+ 'type' => 'test',
+ 'directive' => '',
+ 'description' => 'this is a test',
+ 'test_num' => '1',
+ 'raw' => 'ok 1 this is a test'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# TODO tests
+
+$test = 'not ok 2 this is a test # TODO whee!';
+like $test, $syntax_for{'test'}, 'Tests should match the test syntax';
+
+$stream->put($test);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'ok' => 'not ok',
+ 'explanation' => 'whee!',
+ 'type' => 'test',
+ 'directive' => 'TODO',
+ 'description' => 'this is a test',
+ 'test_num' => '2',
+ 'raw' => 'not ok 2 this is a test # TODO whee!'
+};
+is_deeply $token, $expected, '... and the TODO should be parsed';
+
+# false TODO tests
+
+# escaping that hash mark ('#') means this should *not* be a TODO test
+$test = 'ok 22 this is a test \# TODO whee!';
+like $test, $syntax_for{'test'}, 'Tests should match the test syntax';
+
+$stream->put($test);
+ok $token = $grammar->tokenize,
+ '... and calling it with data should return a token';
+
+$expected = {
+ 'ok' => 'ok',
+ 'explanation' => '',
+ 'type' => 'test',
+ 'directive' => '',
+ 'description' => 'this is a test \# TODO whee!',
+ 'test_num' => '22',
+ 'raw' => 'ok 22 this is a test \# TODO whee!'
+};
+is_deeply $token, $expected,
+ '... and the token should contain the correct data';
+
+# coverage tests
+
+# set_version
+
+{
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $grammar->set_version('no_such_version');
+ };
+
+ unless (is @die, 1, 'set_version with bad version') {
+ diag " >>> $_ <<<\n" for @die;
+ }
+
+ like pop @die, qr/^Unsupported syntax version: no_such_version at /,
+ '... and got expected message';
+}
+
+# tokenize
+{
+ my $stream = SS->new;
+
+ my $grammar = $GRAMMAR->new($stream);
+
+ my $plan = '';
+
+ $stream->put($plan);
+
+ my $result = $grammar->tokenize();
+
+ isa_ok $result, 'TAP::Parser::Result::Unknown';
+}
+
+# _make_plan_token
+
+{
+ my $grammar = $GRAMMAR->new;
+
+ my $plan
+ = '1..1 # SKIP with explanation'; # trigger warning in _make_plan_token
+
+ my $method = $handler_for{'plan'};
+
+ $plan =~ $syntax_for{'plan'}; # perform regex to populate $1, $2
+
+ my @warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $grammar->$method($plan);
+ };
+
+ is @warn, 1, 'catch warning on inconsistent plan';
+
+ like pop @warn,
+ qr/^Specified SKIP directive in plan but more than 0 tests [(]1\.\.1 # SKIP with explanation[)]/,
+ '... and its what we expect';
+}
+
+# _make_yaml_token
+
+{
+ my $stream = SS->new;
+
+ my $grammar = $GRAMMAR->new($stream);
+
+ $grammar->set_version(13);
+
+ # now this is badly formed YAML that is missing the
+ # leader padding - this is done for coverage testing
+ # the $reader code sub in _make_yaml_token, that is
+ # passed as the yaml consumer to T::P::YAMLish::Reader.
+
+ # because it isnt valid yaml, the yaml document is
+ # not done, and the _peek in the YAMLish::Reader
+ # code doesnt find the terminating '...' pattern.
+ # but we dont care as this is coverage testing, so
+ # if thats what we have to do to exercise that code,
+ # so be it.
+ my $yaml = [ ' ... ', '- 2', ' --- ', ];
+
+ sub iter {
+ my $ar = shift;
+ return sub {
+ return shift @$ar;
+ };
+ }
+
+ my $iter = iter($yaml);
+
+ while ( my $line = $iter->() ) {
+ $stream->put($line);
+ }
+
+ # pad == ' ', marker == '--- '
+ # length $pad == 3
+ # strip == pad
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+ $grammar->tokenize;
+ };
+
+ is @die, 1, 'checking badly formed yaml for coverage testing';
+
+ like pop @die, qr/^Missing '[.][.][.]' at end of YAMLish/,
+ '...and it died like we expect';
+}
+
+{
+
+ # coverage testing for TAP::Parser::Iterator::Array
+
+ my $source = [qw( a b c )];
+
+ my $aiter = TAP::Parser::Iterator::Array->new($source);
+
+ my $first = $aiter->next_raw;
+
+ is $first, 'a', 'access raw iterator';
+
+ is $aiter->exit, undef, '... and note we didnt exhaust the source';
+}
-#!/usr/bin/perl -Tw
+#!/usr/bin/perl -w
BEGIN {
- if ( $ENV{PERL_CORE} ) {
+ if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
- unshift @INC, 't/lib';
+ use lib 't/lib';
+ }
+}
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip pending resolution of a clean way to record the change in location of the sample tests\n";
+ exit 0;
}
}
use strict;
-use Test::More tests => 2;
+use Test::More;
+use IO::c55Capture;
-BEGIN {
- use_ok( 'Test::Harness' );
+use TAP::Harness;
+
+my $HARNESS = 'TAP::Harness';
+
+plan tests => 106;
+
+# note that this test will always pass when run through 'prove'
+ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set';
+ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
+
+#### For color tests ####
+
+package Colorizer;
+
+sub new { bless {}, shift }
+sub can_color {1}
+
+sub set_color {
+ my ( $self, $output, $color ) = @_;
+ $output->("[[$color]]");
+}
+
+package main;
+
+sub colorize {
+ my $harness = shift;
+ $harness->formatter->_colorizer( Colorizer->new );
+}
+
+can_ok $HARNESS, 'new';
+
+eval { $HARNESS->new( { no_such_key => 1 } ) };
+like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
+ '... and calling it with bad keys should fail';
+
+eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
+is $@, '', '... and calling it with a non-existent lib is fine';
+
+eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
+is $@, '', '... and calling it with non-existent libs is fine';
+
+ok my $harness = $HARNESS->new,
+ 'Calling new() without arguments should succeed';
+
+foreach my $test_args ( get_arg_sets() ) {
+ my %args = %$test_args;
+ foreach my $key ( sort keys %args ) {
+ $args{$key} = $args{$key}{in};
+ }
+ ok my $harness = $HARNESS->new( {%args} ),
+ 'Calling new() with valid arguments should succeed';
+ isa_ok $harness, $HARNESS, '... and the object it returns';
+
+ while ( my ( $property, $test ) = each %$test_args ) {
+ my $value = $test->{out};
+ can_ok $harness, $property;
+ is_deeply scalar $harness->$property(), $value, $test->{test_name};
+ }
+}
+
+{
+ my @output;
+ local $^W;
+ local *TAP::Formatter::Console::_should_show_count = sub {0};
+ local *TAP::Formatter::Console::_output = sub {
+ my $self = shift;
+ push @output => grep { $_ ne '' }
+ map {
+ local $_ = $_;
+ chomp;
+ trim($_)
+ } @_;
+ };
+ my $harness = TAP::Harness->new( { verbosity => 1 } );
+ my $harness_whisper = TAP::Harness->new( { verbosity => -1 } );
+ my $harness_mute = TAP::Harness->new( { verbosity => -2 } );
+ my $harness_directives = TAP::Harness->new( { directives => 1 } );
+ my $harness_failures = TAP::Harness->new( { failures => 1 } );
+
+ colorize($harness);
+
+ can_ok $harness, 'runtests';
+
+ # normal tests in verbose mode
+
+ ok my $aggregate = _runtests( $harness, 't/source_tests/harness' ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ my @expected = (
+ 't/source_tests/harness....',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'All tests successful.',
+ );
+ my $status = pop @output;
+ my $expected_status = qr{^Result: PASS$};
+ my $summary = pop @output;
+ my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # use an alias for test name
+
+ @output = ();
+ ok $aggregate
+ = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ] ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ @expected = (
+ 'My Nice Test....',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'All tests successful.',
+ );
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # run same test twice
+
+ @output = ();
+ ok $aggregate
+ = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ],
+ [ 't/source_tests/harness', 'My Nice Test Again' ] ),
+ '... runtests returns the aggregate';
+
+ isa_ok $aggregate, 'TAP::Parser::Aggregator';
+
+ chomp(@output);
+
+ @expected = (
+ 'My Nice Test..........',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'My Nice Test Again....',
+ '1..1',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ 'ok',
+ 'All tests successful.',
+ );
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs};
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests in quiet mode
+
+ @output = ();
+ _runtests( $harness_whisper, 't/source_tests/harness' );
+
+ chomp(@output);
+ @expected = (
+ 't/source_tests/harness....',
+ 'ok',
+ 'All tests successful.',
+ );
+
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests in really_quiet mode
+
+ @output = ();
+ _runtests( $harness_mute, 't/source_tests/harness' );
+
+ chomp(@output);
+ @expected = (
+ 'All tests successful.',
+ );
+
+ $status = pop @output;
+ $expected_status = qr{^Result: PASS$};
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $status, $expected_status,
+ '... and the status line should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ # normal tests with failures
+
+ @output = ();
+ _runtests( $harness, 't/source_tests/harness_failure' );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ my @summary = @output[ 10 .. $#output ];
+ @output = @output[ 0 .. 9 ];
+
+ @expected = (
+ 't/source_tests/harness_failure....',
+ '1..2',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ '[[red]]',
+ 'not ok 2 - this is another test',
+ '[[reset]]',
+ '[[red]]',
+ 'Failed 1/2 subtests',
+ );
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ my @expected_summary = (
+ '[[reset]]',
+ 'Test Summary Report',
+ '-------------------',
+ '[[red]]',
+ 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
+ '[[reset]]',
+ '[[red]]',
+ 'Failed test number(s):',
+ '[[reset]]',
+ '[[red]]',
+ '2',
+ '[[reset]]',
+ );
+
+ is_deeply \@summary, \@expected_summary,
+ '... and the failure summary should also be correct';
+
+ # quiet tests with failures
+
+ @output = ();
+ _runtests( $harness_whisper, 't/source_tests/harness_failure' );
+
+ $status = pop @output;
+ $summary = pop @output;
+ @expected = (
+ 't/source_tests/harness_failure....',
+ 'Failed 1/2 subtests',
+ 'Test Summary Report',
+ '-------------------',
+ 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
+ 'Failed test number(s):',
+ '2',
+ );
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ # really quiet tests with failures
+
+ @output = ();
+ _runtests( $harness_mute, 't/source_tests/harness_failure' );
+
+ $status = pop @output;
+ $summary = pop @output;
+ @expected = (
+ 'Test Summary Report',
+ '-------------------',
+ 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
+ 'Failed test number(s):',
+ '2',
+ );
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+
+ # only show directives
+
+ @output = ();
+ _runtests(
+ $harness_directives,
+ 't/source_tests/harness_directives'
+ );
+
+ chomp(@output);
+
+ @expected = (
+ 't/source_tests/harness_directives....',
+ 'not ok 2 - we have a something # TODO some output',
+ "ok 3 houston, we don't have liftoff # SKIP no funding",
+ 'ok',
+ 'All tests successful.',
+
+ # ~TODO {{{ this should be an option
+ #'Test Summary Report',
+ #'-------------------',
+ #'t/source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)',
+ #'Tests skipped:',
+ #'3',
+ # }}}
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+ $expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/;
+
+ is_deeply \@output, \@expected, '... and the output should be correct';
+ like $summary, $expected_summary,
+ '... and the report summary should look correct';
+
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+
+ # normal tests with bad tap
+
+ # install callback handler
+ my $parser;
+ my $callback_count = 0;
+
+ my @callback_log = ();
+
+ for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
+ $harness->callback(
+ $evt => sub {
+ push @callback_log, $evt;
+ }
+ );
+ }
+
+ $harness->callback(
+ made_parser => sub {
+ $parser = shift;
+ $callback_count++;
+ }
+ );
+
+ @output = ();
+ _runtests( $harness, 't/source_tests/harness_badtap' );
+ chomp(@output);
+
+ @output = map { trim($_) } @output;
+ $status = pop @output;
+ @summary = @output[ 12 .. ( $#output - 1 ) ];
+ @output = @output[ 0 .. 11 ];
+ @expected = (
+ 't/source_tests/harness_badtap....',
+ '1..2',
+ '[[reset]]',
+ 'ok 1 - this is a test',
+ '[[reset]]',
+ '[[red]]',
+ 'not ok 2 - this is another test',
+ '[[reset]]',
+ '1..2',
+ '[[reset]]',
+ '[[red]]',
+ 'Failed 1/2 subtests',
+ );
+ is_deeply \@output, \@expected,
+ '... and failing test output should be correct';
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ @expected_summary = (
+ '[[reset]]',
+ 'Test Summary Report',
+ '-------------------',
+ '[[red]]',
+ 't/source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)',
+ '[[reset]]',
+ '[[red]]',
+ 'Failed test number(s):',
+ '[[reset]]',
+ '[[red]]',
+ '2',
+ '[[reset]]',
+ '[[red]]',
+ 'Parse errors: More than one plan found in TAP output',
+ '[[reset]]',
+ );
+ is_deeply \@summary, \@expected_summary,
+ '... and the badtap summary should also be correct';
+
+ cmp_ok( $callback_count, '==', 1, 'callback called once' );
+ is_deeply(
+ \@callback_log,
+ [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
+ 'callback log matches'
+ );
+ isa_ok $parser, 'TAP::Parser';
+
+ # coverage testing for _should_show_failures
+ # only show failures
+
+ @output = ();
+ _runtests( $harness_failures, 't/source_tests/harness_failure' );
+
+ chomp(@output);
+
+ @expected = (
+ 't/source_tests/harness_failure....',
+ 'not ok 2 - this is another test',
+ 'Failed 1/2 subtests',
+ 'Test Summary Report',
+ '-------------------',
+ 't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
+ 'Failed test number(s):',
+ '2',
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
+ is_deeply \@output, \@expected, '... and the output should be correct';
+
+ # check the status output for no tests
+
+ @output = ();
+ _runtests( $harness_failures, 't/sample-tests/no_output' );
+
+ chomp(@output);
+
+ @expected = (
+ 't/sample-tests/no_output....',
+ 'No subtests run',
+ 'Test Summary Report',
+ '-------------------',
+ 't/sample-tests/no_output (Wstat: 0 Tests: 0 Failed: 0)',
+ 'Parse errors: No plan found in TAP output',
+ );
+
+ $status = pop @output;
+ $summary = pop @output;
+
+ like $status, qr{^Result: FAIL$},
+ '... and the status line should be correct';
+ $expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
+ is_deeply \@output, \@expected, '... and the output should be correct';
+
+ #XXXX
+}
+
+# make sure we can exec something ... anything!
+SKIP: {
+
+ my $cat = '/bin/cat';
+ unless ( -e $cat ) {
+ skip "no '$cat'", 2;
+ }
+
+ my $capture = IO::c55Capture->new_handle;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ stdout => $capture,
+ exec => [$cat],
+ }
+ );
+
+ eval { _runtests( $harness, 't/data/catme.1' ) };
+
+ my @output = tied($$capture)->dump;
+ my $status = pop @output;
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+ pop @output; # get rid of summary line
+ my $answer = pop @output;
+ is( $answer, "All tests successful.\n", 'cat meows' );
+}
+
+# catches "exec accumulates arguments" issue (r77)
+{
+ my $capture = IO::c55Capture->new_handle;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ stdout => $capture,
+ exec => [$^X]
+ }
+ );
+
+ _runtests(
+ $harness,
+ 't/source_tests/harness_complain'
+ , # will get mad if run with args
+ 't/source_tests/harness',
+ );
+
+ my @output = tied($$capture)->dump;
+ my $status = pop @output;
+ like $status, qr{^Result: PASS$},
+ '... and the status line should be correct';
+ pop @output; # get rid of summary line
+ is( $output[-1], "All tests successful.\n",
+ 'No exec accumulation'
+ );
+}
+
+sub trim {
+ $_[0] =~ s/^\s+|\s+$//g;
+ return $_[0];
+}
+
+sub liblist {
+ return [ map {"-I$_"} @_ ];
}
-my $strap = Test::Harness->strap;
-isa_ok( $strap, 'Test::Harness::Straps' );
+sub get_arg_sets {
+
+ # keys are keys to new()
+ return {
+ lib => {
+ in => 'lib',
+ out => liblist('lib'),
+ test_name => '... a single lib switch should be correct'
+ },
+ verbosity => {
+ in => 1,
+ out => 1,
+ test_name => '... and we should be able to set verbosity to 1'
+ },
+
+ # verbose => {
+ # in => 1,
+ # out => 1,
+ # test_name => '... and we should be able to set verbose to true'
+ # },
+ },
+ { lib => {
+ in => [ 'lib', 't' ],
+ out => liblist( 'lib', 't' ),
+ test_name => '... multiple lib dirs should be correct'
+ },
+ verbosity => {
+ in => 0,
+ out => 0,
+ test_name => '... and we should be able to set verbosity to 0'
+ },
+
+ # verbose => {
+ # in => 0,
+ # out => 0,
+ # test_name => '... and we should be able to set verbose to false'
+ # },
+ },
+ { switches => {
+ in => [ '-T', '-w', '-T' ],
+ out => [ '-T', '-w', '-T' ],
+ test_name => '... duplicate switches should remain',
+ },
+ failures => {
+ in => 1,
+ out => 1,
+ test_name =>
+ '... and we should be able to set failures to true',
+ },
+ verbosity => {
+ in => -1,
+ out => -1,
+ test_name => '... and we should be able to set verbosity to -1'
+ },
+
+ # quiet => {
+ # in => 1,
+ # out => 1,
+ # test_name => '... and we should be able to set quiet to false'
+ # },
+ },
+
+ { verbosity => {
+ in => -2,
+ out => -2,
+ test_name => '... and we should be able to set verbosity to -2'
+ },
+
+ # really_quiet => {
+ # in => 1,
+ # out => 1,
+ # test_name =>
+ # '... and we should be able to set really_quiet to true',
+ # },
+ exec => {
+ in => $^X,
+ out => $^X,
+ test_name =>
+ '... and we should be able to set the executable',
+ },
+ },
+ { switches => {
+ in => 'T',
+ out => ['T'],
+ test_name =>
+ '... leading dashes (-) on switches are not optional',
+ },
+ },
+ { switches => {
+ in => '-T',
+ out => ['-T'],
+ test_name => '... we should be able to set switches',
+ },
+ failures => {
+ in => 1,
+ out => 1,
+ test_name => '... and we should be able to set failures to true'
+ },
+ };
+}
+
+sub _runtests {
+ my ( $harness, @tests ) = @_;
+ local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
+ my $aggregate = $harness->runtests(@tests);
+ return $aggregate;
+}
+
+{
+
+ # coverage tests for ctor
+
+ my $harness = TAP::Harness->new(
+ { timer => 0,
+ errors => 1,
+ merge => 2,
+
+ # formatter => 3,
+ }
+ );
+
+ is $harness->timer(), 0, 'timer getter';
+ is $harness->timer(10), 10, 'timer setter';
+ is $harness->errors(), 1, 'errors getter';
+ is $harness->errors(10), 10, 'errors setter';
+ is $harness->merge(), 2, 'merge getter';
+ is $harness->merge(10), 10, 'merge setter';
+
+ # jobs accessor
+ is $harness->jobs(), 1, 'jobs';
+}
+
+{
+
+# coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor
+
+ # the coverage tests are
+ # 1. ref $ref => false
+ # 2. ref => ! GLOB and ref->can(print)
+ # 3. ref $ref => GLOB
+
+ # case 1
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ my $harness = TAP::Harness->new(
+ { stdout => bless {}, '0', # how evil is THAT !!!
+ }
+ );
+ };
+
+ is @die, 1, 'bad filehandle to stdout';
+ like pop @die, qr/option 'stdout' needs a filehandle/,
+ '... and we died as expected';
+
+ # case 2
+
+ @die = ();
+
+ package Printable;
+
+ sub new { return bless {}, shift }
+
+ sub print {return}
+
+ package main;
+
+ my $harness = TAP::Harness->new(
+ { stdout => Printable->new(),
+ }
+ );
+
+ isa_ok $harness, 'TAP::Harness';
+
+ # case 3
+
+ @die = ();
+
+ $harness = TAP::Harness->new(
+ { stdout => bless {}, 'GLOB', # again with the evil
+ }
+ );
+
+ isa_ok $harness, 'TAP::Harness';
+}
+
+{
+
+ # coverage testing of lib/switches accessor
+ my $harness = TAP::Harness->new;
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $harness->switches(qw( too many arguments));
+ };
+
+ is @die, 1, 'too many arguments to accessor';
+
+ like pop @die, qr/Too many arguments to method 'switches'/,
+ '...and we died as expected';
+
+ $harness->switches('simple scalar');
+
+ my $arrref = $harness->switches;
+ is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
+}
+
+{
+
+ # coverage tests for the basically untested T::H::_open_spool
+
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool));
+
+# now given that we're going to be writing stuff to the file system, make sure we have
+# a cleanup hook
+
+ END {
+ use File::Path;
+
+ # remove the tree if we made it this far
+ rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
+ if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
+ }
+
+ my $harness = TAP::Harness->new( { verbosity => -2 } );
+
+ can_ok $harness, 'runtests';
+
+ # normal tests in verbose mode
+
+ my $parser = $harness->runtests(
+ File::Spec->catfile(qw (t source_tests harness )) );
+
+ isa_ok $parser, 'TAP::Parser::Aggregator',
+ '... runtests returns the aggregate';
+
+ ok -e File::Spec->catfile(
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP},
+ qw( t source_tests harness )
+ );
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 76;
+
+use File::Spec;
+use TAP::Parser;
+use TAP::Parser::Iterator;
+use Config;
+
+sub array_ref_from {
+ my $string = shift;
+ my @lines = split /\n/ => $string;
+ return \@lines;
+}
+
+# we slurp __DATA__ and then reset it so we don't have to duplicate our TAP
+my $offset = tell DATA;
+my $tap = do { local $/; <DATA> };
+seek DATA, $offset, 0;
+
+my $did_setup = 0;
+my $did_teardown = 0;
+
+my $setup = sub { $did_setup++ };
+my $teardown = sub { $did_teardown++ };
+
+package NoForkProcess;
+use vars qw( @ISA );
+@ISA = qw( TAP::Parser::Iterator::Process );
+
+sub _use_open3 {return}
+
+package main;
+
+my @schedule = (
+ { name => 'Process',
+ subclass => 'TAP::Parser::Iterator::Process',
+ source => {
+ command => [
+ $^X,
+ File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests', 'out_err_mix' )
+ ],
+ merge => 1,
+ setup => $setup,
+ teardown => $teardown,
+ },
+ after => sub {
+ is $did_setup, 1, "setup called";
+ is $did_teardown, 1, "teardown called";
+ },
+ need_open3 => 15,
+ },
+ { name => 'Array',
+ subclass => 'TAP::Parser::Iterator::Array',
+ source => array_ref_from($tap),
+ },
+ { name => 'Stream',
+ subclass => 'TAP::Parser::Iterator::Stream',
+ source => \*DATA,
+ },
+ { name => 'Process (Perl -e)',
+ subclass => 'TAP::Parser::Iterator::Process',
+ source =>
+ { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] },
+ },
+ { name => 'Process (NoFork)',
+ subclass => 'TAP::Parser::Iterator::Process',
+ class => 'NoForkProcess',
+ source =>
+ { command => [ $^X, '-e', 'print qq/one\ntwo\n\nthree\n/' ] },
+ },
+);
+
+sub _can_open3 {
+ return $^O eq 'MSWin32' || $Config{d_fork};
+}
+
+for my $test (@schedule) {
+ SKIP: {
+ my $name = $test->{name};
+ my $need_open3 = $test->{need_open3};
+ skip "No open3", $need_open3 if $need_open3 && !_can_open3();
+ my $subclass = $test->{subclass};
+ my $source = $test->{source};
+ my $class = $test->{class} || 'TAP::Parser::Iterator';
+ ok my $iter = $class->new($source),
+ "$name: We should be able to create a new iterator";
+ isa_ok $iter, 'TAP::Parser::Iterator',
+ '... and the object it returns';
+ isa_ok $iter, $subclass, '... and the object it returns';
+
+ can_ok $iter, 'exit';
+ ok !defined $iter->exit,
+ "$name: ... and it should be undef before we are done ($subclass)";
+
+ can_ok $iter, 'next';
+ is $iter->next, 'one', "$name: next() should return the first result";
+
+ is $iter->next, 'two',
+ "$name: next() should return the second result";
+
+ is $iter->next, '', "$name: next() should return the third result";
+
+ is $iter->next, 'three',
+ "$name: next() should return the fourth result";
+
+ ok !defined $iter->next,
+ "$name: next() should return undef after it is empty";
+
+ is $iter->exit, 0,
+ "$name: ... and exit should now return 0 ($subclass)";
+
+ is $iter->wait, 0, "$name: wait should also now return 0 ($subclass)";
+
+ if ( my $after = $test->{after} ) {
+ $after->();
+ }
+ }
+}
+
+{
+
+ # coverage tests for the ctor
+
+ my $stream = TAP::Parser::Iterator->new( IO::Handle->new );
+
+ isa_ok $stream, 'TAP::Parser::Iterator::Stream';
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ TAP::Parser::Iterator->new( \1 ); # a ref to a scalar
+ };
+
+ is @die, 1, 'coverage of error case';
+
+ like pop @die, qr/Can't iterate with a SCALAR/,
+ '...and we died as expected';
+}
+
+{
+
+ # coverage test for VMS case
+
+ my $stream = TAP::Parser::Iterator->new(
+ [ 'not ',
+ 'ok 1 - I hate VMS',
+ ]
+ );
+
+ is $stream->next, 'not ok 1 - I hate VMS',
+ 'coverage of VMS line-splitting case';
+
+ # coverage test for VMS case - nothing after 'not'
+
+ $stream = TAP::Parser::Iterator->new(
+ [ 'not ',
+ ]
+ );
+
+ is $stream->next, 'not ', '...and we find "not" by itself';
+}
+
+SKIP: {
+ skip "No open3", 4 unless _can_open3();
+
+ # coverage testing for TAP::Parser::Iterator::Process ctor
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ TAP::Parser::Iterator->new( {} );
+ };
+
+ is @die, 1, 'coverage testing for TPI::Process';
+
+ like pop @die, qr/Must supply a command to execute/,
+ '...and we died as expected';
+
+ my $parser = TAP::Parser::Iterator->new(
+ { command => [
+ $^X,
+ File::Spec->catfile( 't', 'sample-tests', 'out_err_mix' )
+ ],
+ merge => 1,
+ }
+ );
+
+ is $parser->{err}, '', 'confirm we set err to empty string';
+ is $parser->{sel}, undef, '...and selector to undef';
+
+ # And then we read from the parser to sidestep the Mac OS / open3
+ # bug which frequently throws an error here otherwise.
+ $parser->next;
+}
+__DATA__
+one
+two
+
+three
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More qw( no_plan );
+
+use File::Spec;
+use TAP::Parser;
+use TAP::Parser::Multiplexer;
+use TAP::Parser::Iterator::Process;
+
+my $fork_desc
+ = TAP::Parser::Iterator::Process->_use_open3
+ ? 'fork'
+ : 'nofork';
+
+my @schedule = (
+ { name => 'Single non-selectable source',
+
+ # Returns a list of parser, stash pairs. The stash contains the
+ # TAP that we expect from this parser.
+ sources => sub {
+ my @tap = (
+ '1..1',
+ 'ok 1 Just fine'
+ );
+
+ return [
+ TAP::Parser->new( { tap => join( "\n", @tap ) . "\n" } ),
+ \@tap,
+ ];
+ },
+ },
+ { name => 'Two non-selectable sources',
+ sources => sub {
+ my @tap = (
+ [ '1..1',
+ 'ok 1 Just fine'
+ ],
+ [ '1..2',
+ 'not ok 1 Oh dear',
+ 'ok 2 Better'
+ ]
+ );
+
+ return map {
+ [ TAP::Parser->new( { tap => join( "\n", @$_ ) . "\n" } ),
+ $_
+ ]
+ } @tap;
+ },
+ },
+ { name => 'Single selectable source',
+ sources => sub {
+ return [
+ TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ($ENV{PERL_CORE} ? 'lib' : 't'), 'sample-tests',
+ 'simple'
+ ),
+ }
+ ),
+ [ '1..5',
+ 'ok 1',
+ 'ok 2',
+ 'ok 3',
+ 'ok 4',
+ 'ok 5',
+ ]
+ ];
+ },
+ },
+ { name => 'Three selectable sources',
+ sources => sub {
+ return map {
+ [ TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests', 'simple'
+ ),
+ }
+ ),
+ [ '1..5',
+ 'ok 1',
+ 'ok 2',
+ 'ok 3',
+ 'ok 4',
+ 'ok 5',
+ ]
+ ]
+ } 1 .. 3;
+ },
+ },
+ { name => 'Three selectable sources, two non-selectable sources',
+ sources => sub {
+ my @tap = (
+ [ '1..1',
+ 'ok 1 Just fine'
+ ],
+ [ '1..2',
+ 'not ok 1 Oh dear',
+ 'ok 2 Better'
+ ]
+ );
+
+ return (
+ map {
+ [ TAP::Parser->new(
+ { tap => join( "\n", @$_ ) . "\n" }
+ ),
+ $_
+ ]
+ } @tap
+ ),
+ ( map {
+ [ TAP::Parser->new(
+ { source => File::Spec->catfile(
+ ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests', 'simple'
+ ),
+ }
+ ),
+ [ '1..5',
+ 'ok 1',
+ 'ok 2',
+ 'ok 3',
+ 'ok 4',
+ 'ok 5',
+ ]
+ ]
+ } 1 .. 3
+ );
+ },
+ }
+);
+
+for my $test (@schedule) {
+ my $name = "$test->{name} ($fork_desc)";
+ my @sources = $test->{sources}->();
+ my $mux = TAP::Parser::Multiplexer->new;
+
+ my $count = @sources;
+ $mux->add(@$_) for @sources;
+
+ is $mux->parsers, $count, "$name: count OK";
+
+ while ( my ( $parser, $stash, $result ) = $mux->next ) {
+
+ # use Data::Dumper;
+ # diag Dumper( { stash => $stash, result => $result } );
+ if ( defined $result ) {
+ my $expect = ( shift @$stash ) || ' OOPS ';
+ my $got = $result->raw;
+ is $got, $expect, "$name: '$expect' OK";
+ }
+ else {
+ ok @$stash == 0, "$name: EOF OK";
+
+ # Make sure we only get one EOF per stream
+ push @$stash, ' expect no more ';
+ }
+ }
+ is $mux->parsers, 0, "$name: All used up";
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use strict;
+
+use NoFork;
+require ($ENV{PERL_CORE} && '../lib/Test/Harness/') . 't/multiplexer.t';
--- /dev/null
+#!/usr/bin/perl -w
+
+# check nofork logic on systems which *can* fork()
+# NOTE maybe a good candidate for xt/author or something.
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip pending resolution of how to set the library with -I\n";
+ exit 0;
+ }
+}
+
+use strict;
+
+use Config;
+use Test::More (
+ $Config{d_fork}
+ ? 'no_plan'
+ : ( 'skip_all' => 'your system already has no fork' )
+);
+use IO::c55Capture; # for util
+
+use TAP::Harness;
+
+sub backticks {
+ my (@args) = @_;
+
+ util::stdout_of( sub { system(@args) and die "error $?" } );
+}
+
+my @perl = ( $^X, '-Ilib', '-It/lib' );
+my $mod = 'TAP::Parser::Iterator::Process';
+
+{ # just check the introspective method to start...
+ my $code = qq(print $mod->_use_open3 ? 1 : 2);
+ {
+ my $ans = backticks( @perl, '-MNoFork', "-M$mod", '-e', $code );
+ is( $ans, 2, 'says not to fork' );
+ }
+ {
+ local $ENV{PERL5OPT}; # punt: prevent propogating -MNoFork
+ my $ans = backticks( @perl, "-M$mod", '-e', $code );
+ is( $ans, 1, 'says to fork' );
+ }
+}
+
+{ # and make sure we can run a test
+ my $capture = IO::c55Capture->new_handle;
+ local *STDERR;
+ my $harness = TAP::Harness->new(
+ { verbosity => -2,
+ switches => [ '-It/lib', "-MNoFork" ],
+ stdout => $capture,
+ }
+ );
+ $harness->runtests(($ENV{PERL_CORE} ? 'lib' : 't') . '/sample-tests/simple');
+ my @output = tied($$capture)->dump;
+ is pop @output, "Result: PASS\n", 'status OK';
+ pop @output; # get rid of summary line
+ is( $output[-1], "All tests successful.\n", 'ran with no fork' );
+}
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ use lib 't/lib';
+ }
+}
+
+use Test::More tests => 260;
+use IO::c55Capture;
+
+use File::Spec;
+
+use TAP::Parser;
+use TAP::Parser::Iterator;
+
+sub _get_results {
+ my $parser = shift;
+ my @results;
+ while ( defined( my $result = $parser->next ) ) {
+ push @results => $result;
+ }
+ return @results;
+}
+
+my ( $PARSER, $PLAN, $TEST, $COMMENT, $BAILOUT, $UNKNOWN, $YAML, $VERSION ) = qw(
+ TAP::Parser
+ TAP::Parser::Result::Plan
+ TAP::Parser::Result::Test
+ TAP::Parser::Result::Comment
+ TAP::Parser::Result::Bailout
+ TAP::Parser::Result::Unknown
+ TAP::Parser::Result::YAML
+ TAP::Parser::Result::Version
+);
+
+my $tap = <<'END_TAP';
+TAP version 13
+1..7
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ --- YAML!
+ ...
+ok 5 # skip we have no description
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+can_ok $PARSER, 'new';
+my $parser = $PARSER->new( { tap => $tap } );
+isa_ok $parser, $PARSER, '... and the object it returns';
+
+ok $ENV{TAP_VERSION}, 'TAP_VERSION env variable should be set';
+
+# results() is sane?
+
+my @results = _get_results($parser);
+is scalar @results, 12, '... and there should be one for each line';
+
+my $version = shift @results;
+isa_ok $version, $VERSION;
+is $version->version, '13', '... and the version should be 13';
+
+# check the test plan
+
+my $result = shift @results;
+isa_ok $result, $PLAN;
+can_ok $result, 'type';
+is $result->type, 'plan', '... and it should report the correct type';
+ok $result->is_plan, '... and it should identify itself as a plan';
+is $result->plan, '1..7', '... and identify the plan';
+ok !$result->directive, '... and this plan should not have a directive';
+ok !$result->explanation, '... or a directive explanation';
+is $result->as_string, '1..7',
+ '... and have the correct string representation';
+is $result->raw, '1..7', '... and raw() should return the original line';
+
+# a normal, passing test
+
+my $test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 1, '... and have the correct test number';
+is $test->description, '- input file opened',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 1 - input file opened',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 1 - input file opened',
+ '... and raw() should return the original line';
+
+# junk lines should be preserved
+
+my $unknown = shift @results;
+isa_ok $unknown, $UNKNOWN;
+is $unknown->type, 'unknown', '... and it should report the correct type';
+ok $unknown->is_unknown, '... and it should identify itself as unknown';
+is $unknown->as_string, '... this is junk',
+ '... and its string representation should be returned verbatim';
+is $unknown->raw, '... this is junk',
+ '... and raw() should return the original line';
+
+# a failing test, which also happens to have a directive
+
+my $failed = shift @results;
+isa_ok $failed, $TEST;
+is $failed->type, 'test', '... and it should report the correct type';
+ok $failed->is_test, '... and it should identify itself as a test';
+is $failed->ok, 'not ok', '... and it should have the correct ok()';
+ok $failed->is_ok, '... and TODO tests should always pass';
+ok !$failed->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $failed->number, 2, '... and have the correct failed number';
+is $failed->description, 'first line of the input valid',
+ '... and the correct description';
+is $failed->directive, 'TODO', '... and should have the correct directive';
+is $failed->explanation, 'some data',
+ '... and the correct directive explanation';
+ok !$failed->has_skip, '... and it is not a SKIPped failed';
+ok $failed->has_todo, '... but it is a TODO succeeded';
+is $failed->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and its string representation should be correct';
+is $failed->raw, 'not ok first line of the input valid # todo some data',
+ '... and raw() should return the original line';
+
+# comments
+
+my $comment = shift @results;
+isa_ok $comment, $COMMENT;
+is $comment->type, 'comment', '... and it should report the correct type';
+ok $comment->is_comment, '... and it should identify itself as a comment';
+is $comment->comment, 'this is a comment',
+ '... and you should be able to fetch the comment';
+is $comment->as_string, '# this is a comment',
+ '... and have the correct string representation';
+is $comment->raw, '# this is a comment',
+ '... and raw() should return the original line';
+
+# another normal, passing test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 3, '... and have the correct test number';
+is $test->description, '- read the rest of the file',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 3 - read the rest of the file',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 3 - read the rest of the file',
+ '... and raw() should return the original line';
+
+# a failing test
+
+$failed = shift @results;
+isa_ok $failed, $TEST;
+is $failed->type, 'test', '... and it should report the correct type';
+ok $failed->is_test, '... and it should identify itself as a test';
+is $failed->ok, 'not ok', '... and it should have the correct ok()';
+ok !$failed->is_ok, '... and the tests should not have passed';
+ok !$failed->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $failed->number, 4, '... and have the correct failed number';
+is $failed->description, '- this is a real failure',
+ '... and the correct description';
+ok !$failed->directive, '... and should have no directive';
+ok !$failed->explanation, '... and no directive explanation';
+ok !$failed->has_skip, '... and it is not a SKIPped failed';
+ok !$failed->has_todo, '... and not a TODO test';
+is $failed->as_string, 'not ok 4 - this is a real failure',
+ '... and its string representation should be correct';
+is $failed->raw, 'not ok 4 - this is a real failure',
+ '... and raw() should return the original line';
+
+# Some YAML
+my $yaml = shift @results;
+isa_ok $yaml, $YAML;
+is $yaml->type, 'yaml', '... and it should report the correct type';
+ok $yaml->is_yaml, '... and it should identify itself as yaml';
+is_deeply $yaml->data, 'YAML!', '... and data should be correct';
+
+# ok 5 # skip we have no description
+# skipped test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 5, '... and have the correct test number';
+ok !$test->description, '... and skipped tests have no description';
+is $test->directive, 'SKIP', '... and teh correct directive';
+is $test->explanation, 'we have no description',
+ '... but we should have an explanation';
+ok $test->has_skip, '... and it is a SKIPped test';
+ok !$test->has_todo, '... but not a TODO test';
+is $test->as_string, 'ok 5 # SKIP we have no description',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 5 # skip we have no description',
+ '... and raw() should return the original line';
+
+# a failing test, which also happens to have a directive
+# ok 6 - you shall not pass! # TODO should have failed
+
+my $bonus = shift @results;
+isa_ok $bonus, $TEST;
+can_ok $bonus, 'todo_passed';
+is $bonus->type, 'test', 'TODO tests should parse correctly';
+ok $bonus->is_test, '... and it should identify itself as a test';
+is $bonus->ok, 'ok', '... and it should have the correct ok()';
+ok $bonus->is_ok, '... and TODO tests should not always pass';
+ok $bonus->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $bonus->number, 6, '... and have the correct failed number';
+is $bonus->description, '- you shall not pass!',
+ '... and the correct description';
+is $bonus->directive, 'TODO', '... and should have the correct directive';
+is $bonus->explanation, 'should have failed',
+ '... and the correct directive explanation';
+ok !$bonus->has_skip, '... and it is not a SKIPped failed';
+ok $bonus->has_todo, '... but it is a TODO succeeded';
+is $bonus->as_string, 'ok 6 - you shall not pass! # TODO should have failed',
+ '... and its string representation should be correct';
+is $bonus->raw, 'ok 6 - you shall not pass! # TODO should have failed',
+ '... and raw() should return the original line';
+ok $bonus->todo_passed,
+ '... todo_bonus() should pass for TODO tests which unexpectedly succeed';
+
+# not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+
+my $passed = shift @results;
+isa_ok $passed, $TEST;
+can_ok $passed, 'todo_passed';
+is $passed->type, 'test', 'TODO tests should parse correctly';
+ok $passed->is_test, '... and it should identify itself as a test';
+is $passed->ok, 'not ok', '... and it should have the correct ok()';
+ok $passed->is_ok, '... and TODO tests should always pass';
+ok !$passed->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok ()';
+is $passed->number, 7, '... and have the correct passed number';
+is $passed->description, '- Gandalf wins. Game over.',
+ '... and the correct description';
+is $passed->directive, 'TODO', '... and should have the correct directive';
+is $passed->explanation, "'bout time!",
+ '... and the correct directive explanation';
+ok !$passed->has_skip, '... and it is not a SKIPped passed';
+ok $passed->has_todo, '... but it is a TODO succeeded';
+is $passed->as_string,
+ "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!",
+ '... and its string representation should be correct';
+is $passed->raw, "not ok 7 - Gandalf wins. Game over. # TODO 'bout time!",
+ '... and raw() should return the original line';
+ok !$passed->todo_passed,
+ '... todo_passed() should not pass for TODO tests which failed';
+
+# test parse results
+
+can_ok $parser, 'passed';
+is $parser->passed, 6,
+ '... and we should have the correct number of passed tests';
+is_deeply [ $parser->passed ], [ 1, 2, 3, 5, 6, 7 ],
+ '... and get a list of the passed tests';
+
+can_ok $parser, 'failed';
+is $parser->failed, 1, '... and the correct number of failed tests';
+is_deeply [ $parser->failed ], [4], '... and get a list of the failed tests';
+
+can_ok $parser, 'actual_passed';
+is $parser->actual_passed, 4,
+ '... and we should have the correct number of actually passed tests';
+is_deeply [ $parser->actual_passed ], [ 1, 3, 5, 6 ],
+ '... and get a list of the actually passed tests';
+
+can_ok $parser, 'actual_failed';
+is $parser->actual_failed, 3,
+ '... and the correct number of actually failed tests';
+is_deeply [ $parser->actual_failed ], [ 2, 4, 7 ],
+ '... or get a list of the actually failed tests';
+
+can_ok $parser, 'todo';
+is $parser->todo, 3,
+ '... and we should have the correct number of TODO tests';
+is_deeply [ $parser->todo ], [ 2, 6, 7 ],
+ '... and get a list of the TODO tests';
+
+can_ok $parser, 'skipped';
+is $parser->skipped, 1,
+ '... and we should have the correct number of skipped tests';
+is_deeply [ $parser->skipped ], [5],
+ '... and get a list of the skipped tests';
+
+# check the plan
+
+can_ok $parser, 'plan';
+is $parser->plan, '1..7', '... and we should have the correct plan';
+is $parser->tests_planned, 7, '... and the correct number of tests';
+
+# "Unexpectedly succeeded"
+can_ok $parser, 'todo_passed';
+is scalar $parser->todo_passed, 1,
+ '... and it should report the number of tests which unexpectedly succeeded';
+is_deeply [ $parser->todo_passed ], [6],
+ '... or *which* tests unexpectedly succeeded';
+
+#
+# Bug report from Torsten Schoenfeld
+# Makes sure parser can handle blank lines
+#
+
+$tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+
+
+ok 2 - read the rest of the file
+END_TAP
+
+my $aref = [ split /\n/ => $tap ];
+
+can_ok $PARSER, 'new';
+$parser = $PARSER->new( { stream => TAP::Parser::Iterator->new($aref) } );
+isa_ok $parser, $PARSER, '... and calling it should succeed';
+
+# results() is sane?
+
+ok @results = _get_results($parser), 'The parser should return results';
+is scalar @results, 5, '... and there should be one for each line';
+
+# check the test plan
+
+$result = shift @results;
+isa_ok $result, $PLAN;
+can_ok $result, 'type';
+is $result->type, 'plan', '... and it should report the correct type';
+ok $result->is_plan, '... and it should identify itself as a plan';
+is $result->plan, '1..2', '... and identify the plan';
+is $result->as_string, '1..2',
+ '... and have the correct string representation';
+is $result->raw, '1..2', '... and raw() should return the original line';
+
+# a normal, passing test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 1, '... and have the correct test number';
+is $test->description, '- input file opened',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 1 - input file opened',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 1 - input file opened',
+ '... and raw() should return the original line';
+
+# junk lines should be preserved
+
+$unknown = shift @results;
+isa_ok $unknown, $UNKNOWN;
+is $unknown->type, 'unknown', '... and it should report the correct type';
+ok $unknown->is_unknown, '... and it should identify itself as unknown';
+is $unknown->as_string, '',
+ '... and its string representation should be returned verbatim';
+is $unknown->raw, '', '... and raw() should return the original line';
+
+# ... and the second empty line
+
+$unknown = shift @results;
+isa_ok $unknown, $UNKNOWN;
+is $unknown->type, 'unknown', '... and it should report the correct type';
+ok $unknown->is_unknown, '... and it should identify itself as unknown';
+is $unknown->as_string, '',
+ '... and its string representation should be returned verbatim';
+is $unknown->raw, '', '... and raw() should return the original line';
+
+# a passing test
+
+$test = shift @results;
+isa_ok $test, $TEST;
+is $test->type, 'test', '... and it should report the correct type';
+ok $test->is_test, '... and it should identify itself as a test';
+is $test->ok, 'ok', '... and it should have the correct ok()';
+ok $test->is_ok, '... and the correct boolean version of is_ok()';
+ok $test->is_actual_ok,
+ '... and the correct boolean version of is_actual_ok()';
+is $test->number, 2, '... and have the correct test number';
+is $test->description, '- read the rest of the file',
+ '... and the correct description';
+ok !$test->directive, '... and not have a directive';
+ok !$test->explanation, '... or a directive explanation';
+ok !$test->has_skip, '... and it is not a SKIPped test';
+ok !$test->has_todo, '... nor a TODO test';
+is $test->as_string, 'ok 2 - read the rest of the file',
+ '... and its string representation should be correct';
+is $test->raw, 'ok 2 - read the rest of the file',
+ '... and raw() should return the original line';
+
+is scalar $parser->passed, 2,
+ 'Empty junk lines should not affect the correct number of tests passed';
+
+# coverage tests
+{
+
+ # calling a TAP::Parser internal method with a 'foreign' class
+
+ my $foreigner = bless {}, 'Foreigner';
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ TAP::Parser::_stream $foreigner, qw(a b c);
+ };
+
+ unless ( is @die, 1, 'coverage testing for TAP::Parser accessors' ) {
+ diag " >>> $_ <<<\n" for @die;
+ }
+
+ like pop @die, qr/_stream[(][)] may not be set externally/,
+ '... and we died with expected message';
+}
+
+{
+
+ # set a spool to write to
+ tie local *SPOOL, 'IO::c55Capture';
+
+ my $tap = <<'END_TAP';
+TAP version 13
+1..7
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ --- YAML!
+ ...
+ok 5 # skip we have no description
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+ {
+ my $parser = $PARSER->new(
+ { tap => $tap,
+ spool => \*SPOOL,
+ }
+ );
+
+ _get_results($parser);
+
+ my @spooled = tied(*SPOOL)->dump();
+
+ is @spooled, 24, 'coverage testing for spool attribute of parser';
+ is join( '', @spooled ), $tap, "spooled tap matches";
+ }
+
+ {
+ my $parser = $PARSER->new(
+ { tap => $tap,
+ spool => \*SPOOL,
+ }
+ );
+
+ $parser->callback( 'ALL', sub { } );
+
+ _get_results($parser);
+
+ my @spooled = tied(*SPOOL)->dump();
+
+ is @spooled, 24, 'coverage testing for spool attribute of parser';
+ is join( '', @spooled ), $tap, "spooled tap matches";
+ }
+}
+
+{
+
+ # _initialize coverage
+
+ my $x = bless [], 'kjsfhkjsdhf';
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $PARSER->new();
+ };
+
+ is @die, 1, 'coverage testing for _initialize';
+
+ like pop @die, qr/PANIC:\s+could not determine stream at/,
+ '...and it failed as expected';
+
+ @die = ();
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $PARSER->new(
+ { stream => 'stream',
+ tap => 'tap',
+ source => 'source', # only one of these is allowed
+ }
+ );
+ };
+
+ is @die, 1, 'coverage testing for _initialize';
+
+ like pop @die,
+ qr/You may only choose one of 'exec', 'stream', 'tap' or 'source'/,
+ '...and it failed as expected';
+}
+
+{
+
+ # coverage of todo_failed
+
+ my $tap = <<'END_TAP';
+TAP version 13
+1..7
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ --- YAML!
+ ...
+ok 5 # skip we have no description
+ok 6 - you shall not pass! # TODO should have failed
+not ok 7 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+ my $parser = $PARSER->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ my @warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { push @warn, @_ };
+
+ $parser->todo_failed;
+ };
+
+ is @warn, 1, 'coverage testing of todo_failed';
+
+ like pop @warn,
+ qr/"todo_failed" is deprecated. Please use "todo_passed". See the docs[.]/,
+ '..and failed as expected'
+}
+
+{
+
+ # coverage testing for T::P::_initialize
+
+ # coverage of the source argument paths
+
+ # ref argument to source
+
+ my $parser = TAP::Parser->new( { source => [ split /$/, $tap ] } );
+
+ isa_ok $parser, 'TAP::Parser';
+
+ isa_ok $parser->_stream, 'TAP::Parser::Iterator::Array';
+
+ # uncategorisable argument to source
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $parser = TAP::Parser->new( { source => 'nosuchfile' } );
+ };
+
+ is @die, 1, 'uncategorisable source';
+
+ like pop @die, qr/Cannot determine source for nosuchfile/,
+ '... and we died as expected';
+}
+
+{
+
+ # coverage test of perl source with switches
+
+ my $parser = TAP::Parser->new(
+ { source => File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests', 'simple' ),
+ }
+ );
+
+ isa_ok $parser, 'TAP::Parser';
+
+ isa_ok $parser->_stream, 'TAP::Parser::Iterator::Process';
+
+ # Workaround for Mac OS X problem wrt closing the iterator without
+ # reading from it.
+ $parser->next;
+}
+
+{
+
+ # coverage testing for TAP::Parser::has_problems
+
+ # we're going to need to test lots of fragments of tap
+ # to cover all the different boolean tests
+
+ # currently covered are no problems and failed, so let's next test
+ # todo_passed
+
+ my $tap = <<'END_TAP';
+TAP version 13
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins. Game over. # TODO 'bout time!
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ ok !$parser->failed;
+ ok $parser->todo_passed;
+
+ ok !$parser->has_problems, 'and has_problems is false';
+
+ # now parse_errors
+
+ $tap = <<'END_TAP';
+TAP version 13
+1..2
+SMACK
+END_TAP
+
+ $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ ok !$parser->failed;
+ ok !$parser->todo_passed;
+ ok $parser->parse_errors;
+
+ ok $parser->has_problems;
+
+ # Now wait and exit are hard to do in an OS platform-independent way, so
+ # we won't even bother
+
+ $tap = <<'END_TAP';
+TAP version 13
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ $parser->wait(1);
+
+ ok !$parser->failed;
+ ok !$parser->todo_passed;
+ ok !$parser->parse_errors;
+
+ ok $parser->wait;
+
+ ok $parser->has_problems;
+
+ # and use the same for exit
+
+ $parser->wait(0);
+ $parser->exit(1);
+
+ ok !$parser->failed;
+ ok !$parser->todo_passed;
+ ok !$parser->parse_errors;
+ ok !$parser->wait;
+
+ ok $parser->exit;
+
+ ok $parser->has_problems;
+}
+
+{
+
+ # coverage testing of the version states
+
+ my $tap = <<'END_TAP';
+TAP version 12
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ my @errors = $parser->parse_errors;
+
+ is @errors, 1, 'test too low version number';
+
+ like pop @errors,
+ qr/Explicit TAP version must be at least 13. Got version 12/,
+ '... and trapped expected version error';
+
+ # now too high a version
+ $tap = <<'END_TAP';
+TAP version 14
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ @errors = $parser->parse_errors;
+
+ is @errors, 1, 'test too high version number';
+
+ like pop @errors,
+ qr/TAP specified version 14 but we don't know about versions later than 13/,
+ '... and trapped expected version error';
+}
+
+{
+
+ # coverage testing of TAP version in the wrong place
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+TAP version 12
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ _get_results($parser);
+
+ my @errors = $parser->parse_errors;
+
+ is @errors, 1, 'test TAP version number in wrong place';
+
+ like pop @errors,
+ qr/If TAP version is present it must be the first line of output/,
+ '... and trapped expected version error';
+
+}
+
+{
+
+ # we're going to bash the internals a bit (but using the API as
+ # much as possible) to force grammar->tokenise() to fail
+
+ # firstly we'll create a stream that dies when its next_raw method is called
+
+ package TAP::Parser::Iterator::Dies;
+
+ use strict;
+ use vars qw(@ISA);
+
+ @ISA = qw(TAP::Parser::Iterator);
+
+ sub new {
+ return bless {}, shift;
+ }
+
+ sub next_raw {
+ die 'this is the dying iterator';
+ }
+
+ # required as part of the TPI interface
+ sub exit { }
+ sub wait { }
+
+ package main;
+
+ # now build a standard parser
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ {
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ # build a dying stream
+ my $stream = TAP::Parser::Iterator::Dies->new;
+
+ # now replace the stream - we're forced to us an T::P intenal
+ # method for this
+ $parser->_stream($stream);
+
+ # build a new grammar
+ my $grammar = TAP::Parser::Grammar->new($stream);
+
+ # replace our grammar with this new one
+ $parser->_grammar($grammar);
+
+ # now call next on the parser, and the grammar should die
+ my $result = $parser->next; # will die in iterator
+
+ is $result, undef, 'iterator dies';
+
+ my @errors = $parser->parse_errors;
+ is @errors, 2, '...and caught expected errrors';
+
+ like shift @errors, qr/this is the dying iterator/,
+ '...and it was what we expected';
+ }
+
+ # Do it all again with callbacks to exercise the other code path in
+ # the unrolled iterator
+ {
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ $parser->callback( 'ALL', sub { } );
+
+ # build a dying stream
+ my $stream = TAP::Parser::Iterator::Dies->new;
+
+ # now replace the stream - we're forced to us an T::P intenal
+ # method for this
+ $parser->_stream($stream);
+
+ # build a new grammar
+ my $grammar = TAP::Parser::Grammar->new($stream);
+
+ # replace our grammar with this new one
+ $parser->_grammar($grammar);
+
+ # now call next on the parser, and the grammar should die
+ my $result = $parser->next; # will die in iterator
+
+ is $result, undef, 'iterator dies';
+
+ my @errors = $parser->parse_errors;
+ is @errors, 2, '...and caught expected errrors';
+
+ like shift @errors, qr/this is the dying iterator/,
+ '...and it was what we expected';
+ }
+}
+
+{
+
+ # coverage testing of TAP::Parser::_next_state
+
+ package TAP::Parser::WithBrokenState;
+ use vars qw(@ISA);
+
+ @ISA = qw( TAP::Parser );
+
+ sub _make_state_table {
+ return { INIT => { plan => { goto => 'FOO' } } };
+ }
+
+ package main;
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser::WithBrokenState->new( { tap => $tap } );
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $parser->next;
+ $parser->next;
+ };
+
+ is @die, 1, 'detect broken state machine';
+
+ like pop @die, qr/Illegal state: FOO/,
+ '...and the message is as we expect';
+}
+
+{
+
+ # coverage testing of TAP::Parser::_iter
+
+ package TAP::Parser::WithBrokenIter;
+ use vars qw(@ISA);
+
+ @ISA = qw( TAP::Parser );
+
+ sub _iter {return}
+
+ package main;
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser::WithBrokenIter->new( { tap => $tap } );
+
+ my @die;
+
+ eval {
+ local $SIG{__WARN__} = sub { };
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $parser->next;
+ };
+
+ is @die, 1, 'detect broken iter';
+
+ like pop @die, qr/Can't use/, '...and the message is as we expect';
+}
+
+{
+
+ # coverage testing of TAP::Parser::_finish
+
+ my $tap = <<'END_TAP';
+1..2
+ok 1 - input file opened
+ok 2 - Gandalf wins
+END_TAP
+
+ my $parser = TAP::Parser->new( { tap => $tap } );
+
+ $parser->tests_run(999);
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ _get_results $parser;
+ };
+
+ is @die, 1, 'detect broken test counts';
+
+ like pop @die,
+ qr/Panic: planned test count [(]1001[)] did not equal sum of passed [(]0[)] and failed [(]2[)] tests!/,
+ '...and the message is as we expect';
+}
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 14;
+
+use TAP::Parser;
+use TAP::Parser::Iterator;
+
+sub tap_to_lines {
+ my $string = shift;
+ my @lines = ( $string =~ /.*\n/g );
+ return \@lines;
+}
+
+my $tap = <<'END_TAP';
+1..4
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+Bail out! We ran out of foobar.
+not ok 5
+END_TAP
+
+my $parser = TAP::Parser->new(
+ { stream => TAP::Parser::Iterator->new( tap_to_lines($tap) ),
+ }
+);
+
+# results() is sane?
+
+# check the test plan
+my $result = $parser->next();
+
+# TEST
+ok $result->is_plan, 'We should have a plan';
+
+# a normal, passing test
+
+my $test = $parser->next();
+
+# TEST
+ok $test->is_test, '... and a test';
+
+# junk lines should be preserved
+
+my $unknown = $parser->next();
+
+# TEST
+ok $unknown->is_unknown, '... and an unknown line';
+
+# a failing test, which also happens to have a directive
+
+my $failed = $parser->next();
+
+# TEST
+ok $failed->is_test, '... and another test';
+
+# comments
+
+my $comment = $parser->next();
+
+# TEST
+ok $comment->is_comment, '... and a comment';
+
+# another normal, passing test
+
+$test = $parser->next();
+
+# TEST
+ok $test->is_test, '... and another test';
+
+# a failing test
+
+$failed = $parser->next();
+
+# TEST
+ok $failed->is_test, '... and yet another test';
+
+# ok 5 # skip we have no description
+# skipped test
+my $bailout = $parser->next();
+
+# TEST
+ok $bailout->is_bailout, 'And finally we should have a bailout';
+
+# TEST
+is $bailout->as_string, 'We ran out of foobar.',
+ '... and as_string() should return the explanation';
+
+# TEST
+is( $bailout->raw, 'Bail out! We ran out of foobar.',
+ '... and raw() should return the explanation'
+);
+
+# TEST
+is( $bailout->explanation, 'We ran out of foobar.',
+ '... and it should have the correct explanation'
+);
+
+my $more_tap = "1..1\nok 1 - input file opened\n";
+
+my $second_parser = TAP::Parser->new(
+ { stream => TAP::Parser::Iterator->new( [ split( /\n/, $more_tap ) ] ),
+ }
+);
+
+$result = $second_parser->next();
+
+# TEST
+ok $result->is_plan(), "Result is not the leftover line";
+
+$result = $second_parser->next();
+
+# TEST
+ok $result->is_test(), "Result is a test";
+
+# TEST
+ok $result->is_ok(), "The event has passed";
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+my $hires;
+
+BEGIN {
+ $hires = eval 'use Time::HiRes qw(sleep); 1';
+}
+
+use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' )
+ : $hires ? ( tests => 9 * 3 )
+ : ( skip_all => 'Need Time::HiRes' ) );
+
+use File::Spec;
+use TAP::Parser::Iterator::Process;
+
+my @expect = (
+ '1..5',
+ 'ok 1 00000',
+ 'ok 2',
+ 'not ok 3',
+ 'ok 4',
+ 'ok 5 00000',
+);
+
+my $source = File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests', 'delayed' );
+
+for my $chunk_size ( 1, 4, 65536 ) {
+ for my $where ( 0 .. 8 ) {
+
+ my $proc = TAP::Parser::Iterator::Process->new(
+ { _chunk_size => $chunk_size,
+ command => [ $^X, $source, ( 1 << $where ) ]
+ }
+ );
+
+ my @got = ();
+ while ( defined( my $line = $proc->next_raw ) ) {
+ push @got, $line;
+ }
+
+ is_deeply \@got, \@expect,
+ "I/O ok with delay at position $where, chunk size $chunk_size";
+ }
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip, needs fixing. Probably an -I issue\n";
+ exit 0;
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+use File::Spec;
+
+use App::Prove;
+
+package FakeProve;
+use vars qw( @ISA );
+
+@ISA = qw( App::Prove );
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->{_log} = [];
+ return $self;
+}
+
+sub _color_default {0}
+
+sub _runtests {
+ my $self = shift;
+ push @{ $self->{_log} }, [ '_runtests', @_ ];
+}
+
+sub get_log {
+ my $self = shift;
+ my @log = @{ $self->{_log} };
+ $self->{_log} = [];
+ return @log;
+}
+
+sub _shuffle {
+ my $self = shift;
+ s/^/xxx/ for @_;
+}
+
+package main;
+
+sub mabs {
+ my $ar = shift;
+ return [ map { File::Spec->rel2abs($_) } @$ar ];
+}
+
+{
+ my @import_log = ();
+
+ sub test_log_import { push @import_log, [@_] }
+
+ sub get_import_log {
+ my @log = @import_log;
+ @import_log = ();
+ return @log;
+ }
+}
+
+my ( @ATTR, %DEFAULT_ASSERTION, @SCHEDULE );
+
+# see the "ACTUAL TEST" section at the bottom
+
+BEGIN { # START PLAN
+
+ # list of attributes
+ @ATTR = qw(
+ archive argv blib color directives exec failures formatter harness
+ includes lib merge parse quiet really_quiet recurse backwards
+ shuffle taint_fail taint_warn verbose warnings_fail warnings_warn
+ );
+
+ # what we expect if the 'expect' hash does not define it
+ %DEFAULT_ASSERTION = map { $_ => undef } @ATTR;
+
+ $DEFAULT_ASSERTION{includes} = $DEFAULT_ASSERTION{argv}
+ = sub { 'ARRAY' eq ref shift };
+
+ my @dummy_tests = map { File::Spec->catdir( 't', 'sample-tests', $_ ) }
+ qw(simple simple_yaml);
+ my $dummy_test = $dummy_tests[0];
+
+ ########################################################################
+ # declarations - this drives all of the subtests.
+ # The cheatsheet follows.
+ # required: name, expect
+ # optional:
+ # args - arguments to constructor
+ # switches - command-line switches
+ # runlog - expected results of internal calls to _runtests, must
+ # match FakeProve's _log attr
+ # run_error - depends on 'runlog' (if missing, asserts no error)
+ # extra - follow-up check to handle exceptional cleanup / verification
+ # class - The App::Prove subclass to test. Defaults to FakeProve
+ @SCHEDULE = (
+ { name => 'Create empty',
+ expect => {}
+ },
+ { name => 'Set all options via constructor',
+ args => {
+ archive => 1,
+ argv => [qw(one two three)],
+ blib => 2,
+ color => 3,
+ directives => 4,
+ exec => 5,
+ failures => 7,
+ formatter => 8,
+ harness => 9,
+ includes => [qw(four five six)],
+ lib => 10,
+ merge => 11,
+ parse => 13,
+ quiet => 14,
+ really_quiet => 15,
+ recurse => 16,
+ backwards => 17,
+ shuffle => 18,
+ taint_fail => 19,
+ taint_warn => 20,
+ verbose => 21,
+ warnings_fail => 22,
+ warnings_warn => 23,
+ },
+ expect => {
+ archive => 1,
+ argv => [qw(one two three)],
+ blib => 2,
+ color => 3,
+ directives => 4,
+ exec => 5,
+ failures => 7,
+ formatter => 8,
+ harness => 9,
+ includes => [qw(four five six)],
+ lib => 10,
+ merge => 11,
+ parse => 13,
+ quiet => 14,
+ really_quiet => 15,
+ recurse => 16,
+ backwards => 17,
+ shuffle => 18,
+ taint_fail => 19,
+ taint_warn => 20,
+ verbose => 21,
+ warnings_fail => 22,
+ warnings_warn => 23,
+ }
+ },
+ { name => 'Call with defaults',
+ args => { argv => [qw( one two three )] },
+ expect => {},
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'one',
+ 'two',
+ 'three'
+ ]
+ ],
+ },
+
+ # Test all options individually
+
+ # { name => 'Just archive',
+ # args => {
+ # argv => [qw( one two three )],
+ # archive => 1,
+ # },
+ # expect => {
+ # archive => 1,
+ # },
+ # runlog => [
+ # [ { archive => 1,
+ # },
+ # 'TAP::Harness',
+ # 'one', 'two',
+ # 'three'
+ # ]
+ # ],
+ # },
+ { name => 'Just argv',
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ argv => [qw( one two three )],
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'one', 'two',
+ 'three'
+ ]
+ ],
+ },
+ { name => 'Just blib',
+ args => {
+ argv => [qw( one two three )],
+ blib => 1,
+ },
+ expect => {
+ blib => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just color',
+ args => {
+ argv => [qw( one two three )],
+ color => 1,
+ },
+ expect => {
+ color => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { color => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just directives',
+ args => {
+ argv => [qw( one two three )],
+ directives => 1,
+ },
+ expect => {
+ directives => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { directives => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just exec',
+ args => {
+ argv => [qw( one two three )],
+ exec => 1,
+ },
+ expect => {
+ exec => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { exec => [1],
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just failures',
+ args => {
+ argv => [qw( one two three )],
+ failures => 1,
+ },
+ expect => {
+ failures => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { failures => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just formatter',
+ args => {
+ argv => [qw( one two three )],
+ formatter => 'TAP::Harness',
+ },
+ expect => {
+ formatter => 'TAP::Harness',
+ },
+ runlog => [
+ [ '_runtests',
+ { formatter_class => 'TAP::Harness',
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ { name => 'Just includes',
+ args => {
+ argv => [qw( one two three )],
+ includes => [qw( four five six )],
+ },
+ expect => {
+ includes => [qw( four five six )],
+ },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [qw( four five six )] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just lib',
+ args => {
+ argv => [qw( one two three )],
+ lib => 1,
+ },
+ expect => {
+ lib => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( ['lib'] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just merge',
+ args => {
+ argv => [qw( one two three )],
+ merge => 1,
+ },
+ expect => {
+ merge => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { merge => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just parse',
+ args => {
+ argv => [qw( one two three )],
+ parse => 1,
+ },
+ expect => {
+ parse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { errors => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just quiet',
+ args => {
+ argv => [qw( one two three )],
+ quiet => 1,
+ },
+ expect => {
+ quiet => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -1
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just really_quiet',
+ args => {
+ argv => [qw( one two three )],
+ really_quiet => 1,
+ },
+ expect => {
+ really_quiet => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -2
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just recurse',
+ args => {
+ argv => [qw( one two three )],
+ recurse => 1,
+ },
+ expect => {
+ recurse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just reverse',
+ args => {
+ argv => [qw( one two three )],
+ backwards => 1,
+ },
+ expect => {
+ backwards => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'three', 'two', 'one'
+ ]
+ ],
+ },
+
+ { name => 'Just shuffle',
+ args => {
+ argv => [qw( one two three )],
+ shuffle => 1,
+ },
+ expect => {
+ shuffle => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ 'xxxone', 'xxxtwo',
+ 'xxxthree'
+ ]
+ ],
+ },
+ { name => 'Just taint_fail',
+ args => {
+ argv => [qw( one two three )],
+ taint_fail => 1,
+ },
+ expect => {
+ taint_fail => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-T'],
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just taint_warn',
+ args => {
+ argv => [qw( one two three )],
+ taint_warn => 1,
+ },
+ expect => {
+ taint_warn => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-t'],
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just verbose',
+ args => {
+ argv => [qw( one two three )],
+ verbose => 1,
+ },
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 1
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just warnings_fail',
+ args => {
+ argv => [qw( one two three )],
+ warnings_fail => 1,
+ },
+ expect => {
+ warnings_fail => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-W'],
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+ { name => 'Just warnings_warn',
+ args => {
+ argv => [qw( one two three )],
+ warnings_warn => 1,
+ },
+ expect => {
+ warnings_warn => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { switches => ['-w'],
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ 'one', 'two', 'three'
+ ]
+ ],
+ },
+
+ # Command line parsing
+ { name => 'Switch -v',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-v', $dummy_test ],
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 1
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --verbose',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--verbose', $dummy_test ],
+ expect => {
+ verbose => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 1
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -f',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-f', $dummy_test ],
+ expect => { failures => 1 },
+ runlog => [
+ [ '_runtests',
+ { failures => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --failures',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--failures', $dummy_test ],
+ expect => { failures => 1 },
+ runlog => [
+ [ '_runtests',
+ { failures => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -l',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-l', $dummy_test ],
+ expect => { lib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( ['lib'] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --lib',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--lib', $dummy_test ],
+ expect => { lib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( ['lib'] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -b',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-b', $dummy_test ],
+ expect => { blib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --blib',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--blib', $dummy_test ],
+ expect => { blib => 1 },
+ runlog => [
+ [ '_runtests',
+ { lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -s',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-s', $dummy_test ],
+ expect => { shuffle => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ "xxx$dummy_test"
+ ]
+ ],
+ },
+
+ { name => 'Switch --shuffle',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--shuffle', $dummy_test ],
+ expect => { shuffle => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ "xxx$dummy_test"
+ ]
+ ],
+ },
+
+ { name => 'Switch -c',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-c', $dummy_test ],
+ expect => { color => 1 },
+ runlog => [
+ [ '_runtests',
+ { color => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -r',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-r', $dummy_test ],
+ expect => { recurse => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --recurse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--recurse', $dummy_test ],
+ expect => { recurse => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --reverse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--reverse', @dummy_tests ],
+ expect => { backwards => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ reverse @dummy_tests
+ ]
+ ],
+ },
+
+ { name => 'Switch -p',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-p', $dummy_test ],
+ expect => {
+ parse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { errors => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --parse',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--parse', $dummy_test ],
+ expect => {
+ parse => 1,
+ },
+ runlog => [
+ [ '_runtests',
+ { errors => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -q',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-q', $dummy_test ],
+ expect => { quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -1
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --quiet',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--quiet', $dummy_test ],
+ expect => { quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -1
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -Q',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-Q', $dummy_test ],
+ expect => { really_quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -2
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --QUIET',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--QUIET', $dummy_test ],
+ expect => { really_quiet => 1 },
+ runlog => [
+ [ '_runtests',
+ { verbosity => -2
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch -m',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-m', $dummy_test ],
+ expect => { merge => 1 },
+ runlog => [
+ [ '_runtests',
+ { merge => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --merge',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--merge', $dummy_test ],
+ expect => { merge => 1 },
+ runlog => [
+ [ '_runtests',
+ { merge => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Switch --directives',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--directives', $dummy_test ],
+ expect => { directives => 1 },
+ runlog => [
+ [ '_runtests',
+ { directives => 1,
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # Executing one word (why would it be a -s though?)
+ { name => 'Switch --exec -s',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--exec', '-s', $dummy_test ],
+ expect => { exec => '-s' },
+ runlog => [
+ [ '_runtests', { exec => ['-s'], verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # multi-part exec
+ { name => 'Switch --exec "/foo/bar/perl -Ilib"',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '--exec', '/foo/bar/perl -Ilib', $dummy_test ],
+ expect => { exec => '/foo/bar/perl -Ilib' },
+ runlog => [
+ [ '_runtests',
+ { exec => [qw(/foo/bar/perl -Ilib)],
+ verbosity => 0
+ },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # null exec (run tests as compiled binaries)
+ { name => 'Switch --exec ""',
+ switches => [ '--exec', '', $dummy_test ],
+ expect => {
+ exec => # ick, must workaround the || default bit with a sub
+ sub { my $val = shift; defined($val) and !length($val) }
+ },
+ runlog => [
+ [ '_runtests',
+ { exec => [], verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # Plugins
+ { name => 'Load plugin',
+ switches => [ '-P', 'Dummy', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load plugin (args)',
+ switches => [ '-P', 'Dummy=cracking,cheese,gromit', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded,
+ [ [ 'App::Prove::Plugin::Dummy', 'cracking', 'cheese',
+ 'gromit'
+ ]
+ ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load plugin (explicit path)',
+ switches => [ '-P', 'App::Prove::Plugin::Dummy', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ { name => 'Load module',
+ switches => [ '-M', 'App::Prove::Plugin::Dummy', $dummy_test ],
+ args => {
+ argv => [qw( one two three )],
+ },
+ expect => {
+ plugins => ['Dummy'],
+ },
+ extra => sub {
+ my @loaded = get_import_log();
+ is_deeply \@loaded, [ ['App::Prove::Plugin::Dummy'] ],
+ "Plugin loaded OK";
+ },
+ plan => 1,
+ runlog => [
+ [ '_runtests',
+ { verbosity => 0 },
+ 'TAP::Harness',
+ $dummy_test
+ ]
+ ],
+ },
+
+ # TODO
+ # Hmm, that doesn't work...
+ # { name => 'Switch -h',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-h', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ '_runtests',
+ # {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+
+ # { name => 'Switch --help',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--help', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ # { name => 'Switch -?',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-?', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch -H',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-H', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --man',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--man', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch -V',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-V', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --version',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--version', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --color!',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--color!', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ { name => 'Switch -I=s@',
+ args => {
+ argv => [qw( one two three )],
+ },
+ switches => [ '-Ilib', $dummy_test ],
+ expect => {
+ includes => sub {
+ my ( $val, $attr ) = @_;
+ return
+ 'ARRAY' eq ref $val
+ && 1 == @$val
+ && $val->[0] =~ /lib$/;
+ },
+ },
+ },
+
+ # { name => 'Switch -a',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-a', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --archive=-s',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--archive=-s', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --formatter=-s',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--formatter=-s', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch -e',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '-e', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+ #
+ # { name => 'Switch --harness=-s',
+ # args => {
+ # argv => [qw( one two three )],
+ # },
+ # switches => [ '--harness=-s', $dummy_test ],
+ # expect => {},
+ # runlog => [
+ # [ {},
+ # 'TAP::Harness',
+ # $dummy_test
+ # ]
+ # ],
+ # },
+
+ );
+
+ # END SCHEDULE
+ ########################################################################
+
+ my $extra_plan = 0;
+ for my $test (@SCHEDULE) {
+ $extra_plan += $test->{plan} || 0;
+ $extra_plan += 2 if $test->{runlog};
+ $extra_plan += 1 if $test->{switches};
+ }
+
+ plan tests => @SCHEDULE * ( 3 + @ATTR ) + $extra_plan;
+} # END PLAN
+
+# ACTUAL TEST
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+ my $class = $test->{class} || 'FakeProve';
+
+ ok my $app = $class->new( exists $test->{args} ? $test->{args} : () ),
+ "$name: App::Prove created OK";
+
+ isa_ok $app, 'App::Prove';
+ isa_ok $app, $class;
+
+ # Optionally parse command args
+ if ( my $switches = $test->{switches} ) {
+ eval { $app->process_args( '--norc', @$switches ) };
+ if ( my $err_pattern = $test->{parse_error} ) {
+ like $@, $err_pattern, "$name: expected parse error";
+ }
+ else {
+ ok !$@, "$name: no parse error";
+ }
+ }
+
+ my $expect = $test->{expect} || {};
+ for my $attr ( sort @ATTR ) {
+ my $val = $app->$attr();
+ my $assertion = $expect->{$attr} || $DEFAULT_ASSERTION{$attr};
+ my $is_ok = undef;
+
+ if ( 'CODE' eq ref $assertion ) {
+ $is_ok = ok $assertion->( $val, $attr ),
+ "$name: $attr has the expected value";
+ }
+ elsif ( 'Regexp' eq ref $assertion ) {
+ $is_ok = like $val, $assertion, "$name: $attr matches $assertion";
+ }
+ else {
+ $is_ok = is_deeply $val, $assertion,
+ "$name: $attr has the expected value";
+ }
+
+ unless ($is_ok) {
+ diag "got $val for $attr";
+ }
+ }
+
+ if ( my $runlog = $test->{runlog} ) {
+ eval { $app->run };
+ if ( my $err_pattern = $test->{run_error} ) {
+ like $@, $err_pattern, "$name: expected error OK";
+ pass;
+ pass for 1 .. $test->{plan};
+ }
+ else {
+ unless ( ok !$@, "$name: no error OK" ) {
+ diag "$name: error: $@\n";
+ }
+
+ my $gotlog = [ $app->get_log ];
+
+ if ( my $extra = $test->{extra} ) {
+ $extra->($gotlog);
+ }
+
+ unless (
+ is_deeply $gotlog, $runlog,
+ "$name: run results match"
+ )
+ {
+ use Data::Dumper;
+ diag Dumper( { wanted => $runlog, got => $gotlog } );
+ }
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip, needs fixing. Probably an -I issue\n";
+ exit 0;
+ }
+}
+
+use strict;
+use lib 't/lib';
+use Test::More tests => 1;
+use File::Spec;
+use App::Prove;
+
+my $prove = App::Prove->new;
+
+$prove->add_rc_file( File::Spec->catfile( 't', 'data', 'proverc' ) );
+
+is_deeply $prove->{rc_opts},
+ [ '--should', 'be', '--split', 'correctly', 'Can', 'quote things',
+ 'using single or', 'double quotes', '--this', 'is', 'OK?' ],
+ 'options parsed';
+
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip, needs fixing. Probably an -I issue\n";
+ exit 0;
+ }
+}
+
+use strict;
+
+use lib 't/lib';
+
+use Test::More;
+use File::Spec;
+use App::Prove;
+
+my @SCHEDULE;
+
+BEGIN {
+
+ my $sample_test
+ = File::Spec->catfile( split /\//, 't/sample-tests/simple' );
+
+ @SCHEDULE = (
+ { name => 'Create empty',
+ args => [$sample_test],
+ expect => [
+ [ 'new',
+ 'TAP::Parser::Iterator::Process',
+ { merge => undef,
+ command => [
+ 'PERL',
+ $sample_test
+ ],
+ setup => \'CODE',
+ teardown => \'CODE',
+
+ }
+ ]
+ ]
+ },
+ );
+
+ plan tests => @SCHEDULE * 2;
+}
+
+# Waaaaay too much boilerplate
+
+package FakeProve;
+use vars qw( @ISA );
+
+@ISA = qw( App::Prove );
+
+sub new {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->{_log} = [];
+ return $self;
+}
+
+sub _exit {
+ my $self = shift;
+ push @{ $self->{_log} }, [ '_exit', @_ ];
+ die "Exited";
+}
+
+sub get_log {
+ my $self = shift;
+ my @log = @{ $self->{_log} };
+ $self->{_log} = [];
+ return @log;
+}
+
+package main;
+
+{
+ use TAP::Parser::Iterator::Process;
+ use TAP::Formatter::Console;
+
+ # Patch TAP::Parser::Iterator::Process
+ my @call_log = ();
+
+ local $^W; # no warnings
+
+ my $orig_new = \&TAP::Parser::Iterator::Process::new;
+ *TAP::Parser::Iterator::Process::new = sub {
+ push @call_log, [ 'new', @_ ];
+
+ # And then new turns round and tramples on our args...
+ $_[1] = { %{ $_[1] } };
+ $orig_new->(@_);
+ };
+
+ # Patch TAP::Formatter::Console;
+ my $orig_output = \&TAP::Formatter::Console::_output;
+ *TAP::Formatter::Console::_output = sub {
+
+ # push @call_log, [ '_output', @_ ];
+ };
+
+ sub get_log {
+ my @log = @call_log;
+ @call_log = ();
+ return @log;
+ }
+}
+
+sub _slacken {
+ my $obj = shift;
+ if ( my $ref = ref $obj ) {
+ if ( 'HASH' eq ref $obj ) {
+ return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
+ }
+ elsif ( 'ARRAY' eq ref $obj ) {
+ return [ map { _slacken($_) } @$obj ];
+ }
+ elsif ( 'SCALAR' eq ref $obj ) {
+ return $obj;
+ }
+ else {
+ return \$ref;
+ }
+ }
+ else {
+ return $obj;
+ }
+}
+
+sub is_slackly($$$) {
+ my ( $got, $want, $msg ) = @_;
+ return is_deeply _slacken($got), _slacken($want), $msg;
+}
+
+# ACTUAL TEST
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+
+ my $app = FakeProve->new;
+ $app->process_args( '--norc', @{ $test->{args} } );
+
+ # Why does this make the output from the test spew out of
+ # our STDOUT?
+ eval { $app->run };
+ like $@, qr{Exited}, "$name: exited via _exit()";
+
+ my @log = get_log();
+
+ # Bodge: we don't know what pathname will be used for the exe so we
+ # obliterate it here. Need to test that it's sane.
+ for my $call (@log) {
+ if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
+ $call->[2]->{command}->[0] = 'PERL';
+ }
+ }
+
+ is_slackly \@log, $test->{expect}, "$name: command args OK";
+
+ # use Data::Dumper;
+ # diag Dumper(
+ # { got => \@log,
+ # expect => $test->{expect}
+ # }
+ # );
+}
+
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ chdir 't' and @INC = '../lib' if $ENV{PERL_CORE};
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More 'no_plan';
+
+use File::Spec;
+use Config;
+
+use constant TRUE => "__TRUE__";
+use constant FALSE => "__FALSE__";
+
+# if wait() is non-zero, we cannot reliably predict its value
+use constant NOT_ZERO => "__NOT_ZERO__";
+
+use TAP::Parser;
+
+my $IsVMS = $^O eq 'VMS';
+my $IsWin32 = $^O eq 'MSWin32';
+
+my $SAMPLE_TESTS
+ = File::Spec->catdir( File::Spec->curdir, ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests' );
+
+my %deprecated = map { $_ => 1 } qw(
+ TAP::Parser::good_plan
+ TAP::Parser::Result::Plan::passed
+ TAP::Parser::Result::Test::passed
+ TAP::Parser::Result::Test::actual_passed
+ TAP::Parser::Result::passed
+);
+$SIG{__WARN__} = sub {
+ if ( $_[0] =~ /is deprecated/ ) {
+ my @caller = caller(1);
+ my $sub = $caller[3];
+ ok exists $deprecated{$sub},
+ "... we should get a deprecated warning for $sub";
+ }
+ else {
+ CORE::warn @_;
+ }
+};
+
+# the %samples keys are the names of test scripts in t/sample-tests
+my %samples = (
+ descriptive => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "Interlock activated",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "Megathrusters are go",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "Head formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "Blazing sword formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "Robeast destroyed",
+ is_unplanned => FALSE,
+ }
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ descriptive_trailing => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "Interlock activated",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "Megathrusters are go",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "Head formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "Blazing sword formed",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "Robeast destroyed",
+ is_unplanned => FALSE,
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ empty => {
+ results => [],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ is_good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 0,
+ parse_errors => ['No plan found in TAP output'],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ simple => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ space_after_plan => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5 ',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ simple_yaml => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { is_yaml => TRUE,
+ data => [
+ { 'fnurk' => 'skib', 'ponk' => 'gleeb' },
+ { 'bar' => 'krup', 'foo' => 'plink' }
+ ],
+ raw =>
+ " ---\n -\n fnurk: skib\n ponk: gleeb\n -\n bar: krup\n foo: plink\n ...",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { is_yaml => TRUE,
+ data => {
+ 'got' => [ '1', 'pong', '4' ],
+ 'expected' => [ '1', '2', '4' ]
+ },
+ raw =>
+ " ---\n expected:\n - 1\n - 2\n - 4\n got:\n - 1\n - pong\n - 4\n ...",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 13,
+ },
+ simple_fail => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1, 3, 4 ],
+ actual_passed => [ 1, 3, 4 ],
+ failed => [ 2, 5 ],
+ actual_failed => [ 2, 5 ],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ skip => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => TRUE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ explanation => 'rain delay',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [2],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ skip_nomsg => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => TRUE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ ],
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [1],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ todo_inline => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..3',
+ tests_planned => 3,
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 1,
+ description => "- Foo",
+ explanation => 'Just testing the todo interface.',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 2,
+ description => "- Unexpected success",
+ explanation => 'Just testing the todo interface.',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "- This is not todo",
+ explanation => '',
+ },
+ ],
+ plan => '1..3',
+ passed => [ 1, 2, 3 ],
+ actual_passed => [ 2, 3 ],
+ failed => [],
+ actual_failed => [1],
+ todo => [ 1, 2 ],
+ todo_passed => [2],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 3,
+ tests_run => 3,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ todo => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..5 todo 3 2;',
+ tests_planned => 5,
+ todo_list => [ 3, 2 ],
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 2,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 3,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ explanation => '',
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1, 2, 3, 4, 5 ],
+ actual_passed => [ 1, 2, 4, 5 ],
+ failed => [],
+ actual_failed => [3],
+ todo => [ 2, 3 ],
+ todo_passed => [2],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ duplicates => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..10',
+ tests_planned => 10,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 7,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 8,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 9,
+ description => '',
+ explanation => '',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 10,
+ description => '',
+ explanation => '',
+ is_unplanned => TRUE,
+ },
+ ],
+ plan => '1..10',
+ passed => [ 1 .. 4, 4 .. 9 ],
+ actual_passed => [ 1 .. 4, 4 .. 10 ],
+ failed => [10],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 10,
+ tests_run => 11,
+ parse_errors => [
+ 'Tests out of sequence. Found (4) but expected (5)',
+ 'Tests out of sequence. Found (5) but expected (6)',
+ 'Tests out of sequence. Found (6) but expected (7)',
+ 'Tests out of sequence. Found (7) but expected (8)',
+ 'Tests out of sequence. Found (8) but expected (9)',
+ 'Tests out of sequence. Found (9) but expected (10)',
+ 'Tests out of sequence. Found (10) but expected (11)',
+ 'Bad plan. You planned 10 tests but ran 11.',
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ no_nums => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ }
+ ],
+ plan => '1..5',
+ passed => [ 1, 2, 4, 5 ],
+ actual_passed => [ 1, 2, 4, 5 ],
+ failed => [3],
+ actual_failed => [3],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ bailout => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { is_bailout => TRUE,
+ explanation => "GERONIMMMOOOOOO!!!",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ }
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ no_output => {
+ results => [],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 0,
+ parse_errors => [ 'No plan found in TAP output', ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ too_many => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..3',
+ tests_planned => 3,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 7,
+ description => "",
+ is_unplanned => TRUE,
+ },
+ ],
+ plan => '1..3',
+ passed => [ 1 .. 3 ],
+ actual_passed => [ 1 .. 7 ],
+ failed => [ 4 .. 7 ],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 3,
+ tests_run => 7,
+ parse_errors => ['Bad plan. You planned 3 tests but ran 7.'],
+ 'exit' => 4,
+ wait => NOT_ZERO,
+ skip_if => sub {$IsVMS},
+ },
+ taint => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "- -T honored",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ ],
+ plan => '1..1',
+ passed => [ 1 .. 1 ],
+ actual_passed => [ 1 .. 1 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => TRUE,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ 'die' => {
+ results => [],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 0,
+ parse_errors => [ 'No plan found in TAP output', ],
+ 'exit' => NOT_ZERO,
+ wait => NOT_ZERO,
+ },
+ die_head_end => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => undef,
+ tests_run => 4,
+ parse_errors => [ 'No plan found in TAP output', ],
+ 'exit' => NOT_ZERO,
+ wait => NOT_ZERO,
+ },
+ die_last_minute => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => NOT_ZERO,
+ wait => NOT_ZERO,
+ },
+ bignum => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 136211425,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 136211426,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1, 2 ],
+ actual_passed => [ 1, 2, 136211425, 136211426 ],
+ failed => [ 136211425, 136211426 ],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 2,
+ tests_run => 4,
+ parse_errors => [
+ 'Tests out of sequence. Found (136211425) but expected (3)',
+ 'Tests out of sequence. Found (136211426) but expected (4)',
+ 'Bad plan. You planned 2 tests but ran 4.'
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ bignum_many => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 99997,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 99998,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 99999,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100000,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100001,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100002,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100003,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100004,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 100005,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1, 2 ],
+ actual_passed => [ 1, 2, 99997 .. 100005 ],
+ failed => [ 99997 .. 100005 ],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ tests_planned => 2,
+ tests_run => 11,
+ parse_errors => [
+ 'Tests out of sequence. Found (99997) but expected (3)',
+ 'Tests out of sequence. Found (99998) but expected (4)',
+ 'Tests out of sequence. Found (99999) but expected (5)',
+ 'Tests out of sequence. Found (100000) but expected (6)',
+ 'Tests out of sequence. Found (100001) but expected (7)',
+ 'Tests out of sequence. Found (100002) but expected (8)',
+ 'Tests out of sequence. Found (100003) but expected (9)',
+ 'Tests out of sequence. Found (100004) but expected (10)',
+ 'Tests out of sequence. Found (100005) but expected (11)',
+ 'Bad plan. You planned 2 tests but ran 11.'
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ combined => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..10',
+ tests_planned => 10,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => 'basset hounds got long ears',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => 'all hell broke loose',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 4,
+ description => '',
+ explanation => 'if I heard a voice from heaven ...',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => 'say "live without loving",',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => "I'd beg off.",
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => '1',
+ has_todo => FALSE,
+ number => 7,
+ description => '',
+ explanation => 'contract negotiations',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 8,
+ description => 'Girls are such exquisite hell',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => TRUE,
+ number => 9,
+ description => 'Elegy 9B',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 10,
+ description => '',
+ explanation => '',
+ },
+ ],
+ plan => '1..10',
+ passed => [ 1 .. 2, 4 .. 9 ],
+ actual_passed => [ 1 .. 2, 5 .. 9 ],
+ failed => [ 3, 10 ],
+ actual_failed => [ 3, 4, 10 ],
+ todo => [ 4, 9 ],
+ todo_passed => [9],
+ skipped => [7],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 10,
+ tests_run => 10,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ head_end => {
+ results => [
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comments',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comment',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'more ignored stuff',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'and yet more',
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ head_fail => {
+ results => [
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comments',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comment',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'more ignored stuff',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'and yet more',
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1, 3, 4 ],
+ actual_passed => [ 1, 3, 4 ],
+ failed => [2],
+ actual_failed => [2],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ out_of_order => {
+ results => [
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '- Test that argument passing works',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description =>
+ '- Test that passing arguments as references work',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '- Test a normal sub',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 6,
+ description => '- Detach test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 8,
+ description => '- Nested thread test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 9,
+ description => '- Nested thread test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 10,
+ description => '- Wanted 7, got 7',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 11,
+ description => '- Wanted 7, got 7',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 12,
+ description => '- Wanted 8, got 8',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 13,
+ description => '- Wanted 8, got 8',
+ explanation => '',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..15',
+ tests_planned => 15,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => '- Check that Config::threads is true',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 7,
+ description => '- Detach test',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 14,
+ description =>
+ '- Check so that tid for threads work for main thread',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 15,
+ description =>
+ '- Check so that tid for threads work for main thread',
+ explanation => '',
+ },
+ ],
+ plan => '1..15',
+ passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ],
+ actual_passed => [ 2 .. 4, 6, 8 .. 13, 1, 5, 7, 14, 15 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ is_good_plan => FALSE,
+ tests_planned => 15,
+ tests_run => 15,
+
+ # Note that tests 14 and 15 *are* in the correct sequence.
+ parse_errors => [
+ 'Tests out of sequence. Found (2) but expected (1)',
+ 'Tests out of sequence. Found (3) but expected (2)',
+ 'Tests out of sequence. Found (4) but expected (3)',
+ 'Tests out of sequence. Found (6) but expected (4)',
+ 'Tests out of sequence. Found (8) but expected (5)',
+ 'Tests out of sequence. Found (9) but expected (6)',
+ 'Tests out of sequence. Found (10) but expected (7)',
+ 'Tests out of sequence. Found (11) but expected (8)',
+ 'Tests out of sequence. Found (12) but expected (9)',
+ 'Tests out of sequence. Found (13) but expected (10)',
+ 'Plan (1..15) must be at the beginning or end of the TAP output',
+ 'Tests out of sequence. Found (1) but expected (11)',
+ 'Tests out of sequence. Found (5) but expected (12)',
+ 'Tests out of sequence. Found (7) but expected (13)',
+ ],
+ 'exit' => 0,
+ wait => 0,
+ },
+ skipall => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..0 # skipping: rope',
+ tests_planned => 0,
+ passed => TRUE,
+ is_ok => TRUE,
+ directive => 'SKIP',
+ explanation => 'rope'
+ },
+ ],
+ plan => '1..0',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 0,
+ tests_run => 0,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ skip_all => 'rope',
+ },
+ skipall_v13 => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_unknown => TRUE,
+ raw => '1..0 # skipping: rope',
+ },
+ ],
+ plan => '',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => FALSE,
+ is_good_plan => FALSE,
+ tests_planned => FALSE,
+ tests_run => 0,
+ parse_errors => ['No plan found in TAP output'],
+ 'exit' => 0,
+ wait => 0,
+ version => 13,
+ },
+ skipall_nomsg => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..0',
+ tests_planned => 0,
+ passed => TRUE,
+ is_ok => TRUE,
+ directive => 'SKIP',
+ explanation => ''
+ },
+ ],
+ plan => '1..0',
+ passed => [],
+ actual_passed => [],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 0,
+ tests_run => 0,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ skip_all => '(no reason given)',
+ },
+ todo_misparse => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..1',
+ tests_planned => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => FALSE,
+ is_actual_ok => FALSE,
+ passed => FALSE,
+ is_ok => FALSE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => 'Hamlette # TODOORNOTTODO',
+ explanation => '',
+ },
+ ],
+ plan => '1..1',
+ passed => [],
+ actual_passed => [],
+ failed => [1],
+ actual_failed => [1],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => TRUE,
+ tests_run => 1,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ shbang_misparse => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => "",
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1 .. 2 ],
+ actual_passed => [ 1 .. 2 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 2,
+ tests_run => 2,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ switches => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ ],
+ __ARGS__ => { switches => ['-Mstrict'] },
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ inc_taint => {
+ results => [
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ explanation => '',
+ },
+ ],
+ __ARGS__ => { switches => ['-Iexamples'] },
+ plan => '1..1',
+ passed => [1],
+ actual_passed => [1],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => TRUE,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ sequence_misparse => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "\# skipped on foobar system",
+ },
+ { is_comment => TRUE,
+ comment => '1234567890123456789012345678901234567890',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { is_comment => TRUE,
+ comment => '1234567890123456789012345678901234567890',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+
+ stdout_stderr => {
+ results => [
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comments',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => '',
+ explanation => '',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'comment',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => '',
+ explanation => '',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'more ignored stuff',
+ },
+ { is_comment => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ comment => 'and yet more',
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..4',
+ tests_planned => 4,
+ },
+ ],
+ plan => '1..4',
+ passed => [ 1 .. 4 ],
+ actual_passed => [ 1 .. 4 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 4,
+ tests_run => 4,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ need_open3 => 1,
+ },
+
+ junk_before_plan => {
+ results => [
+ { is_unknown => TRUE,
+ raw => 'this is junk',
+ },
+ { is_comment => TRUE,
+ comment => "this is a comment",
+ },
+ { is_plan => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ raw => '1..1',
+ tests_planned => 1,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ },
+ ],
+ plan => '1..1',
+ passed => [ 1 .. 1 ],
+ actual_passed => [ 1 .. 1 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 1,
+ tests_run => 1,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ version_good => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 13,
+ },
+ version_old => {
+ results => [
+ { is_version => TRUE,
+ raw => 'TAP version 12',
+ },
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors =>
+ ['Explicit TAP version must be at least 13. Got version 12'],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+ version_late => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..5',
+ tests_planned => 5,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { is_version => TRUE,
+ raw => 'TAP version 13',
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 4,
+ description => "",
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 5,
+ description => "",
+ },
+ ],
+ plan => '1..5',
+ passed => [ 1 .. 5 ],
+ actual_passed => [ 1 .. 5 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 5,
+ tests_run => 5,
+ parse_errors =>
+ ['If TAP version is present it must be the first line of output'],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+
+ escape_eol => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..2',
+ tests_planned => 2,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description =>
+ 'Should parse as literal backslash --> \\',
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => 'Not a continuation line',
+ is_unplanned => FALSE,
+ },
+ ],
+ plan => '1..2',
+ passed => [ 1 .. 2 ],
+ actual_passed => [ 1 .. 2 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 2,
+ tests_run => 2,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+
+ escape_hash => {
+ results => [
+ { is_plan => TRUE,
+ raw => '1..3',
+ tests_planned => 3,
+ passed => TRUE,
+ is_ok => TRUE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ description => 'Not a \\# TODO',
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 1,
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 2,
+ description => 'Not a \\# SKIP',
+ is_unplanned => FALSE,
+ },
+ { actual_passed => TRUE,
+ is_actual_ok => TRUE,
+ passed => TRUE,
+ is_ok => TRUE,
+ is_test => TRUE,
+ has_skip => FALSE,
+ has_todo => FALSE,
+ number => 3,
+ description => 'Escaped \\\\\\#',
+ is_unplanned => FALSE,
+ },
+ ],
+ plan => '1..3',
+ passed => [ 1 .. 3 ],
+ actual_passed => [ 1 .. 3 ],
+ failed => [],
+ actual_failed => [],
+ todo => [],
+ todo_passed => [],
+ skipped => [],
+ good_plan => TRUE,
+ is_good_plan => TRUE,
+ tests_planned => 3,
+ tests_run => 3,
+ parse_errors => [],
+ 'exit' => 0,
+ wait => 0,
+ version => 12,
+ },
+);
+
+my %HANDLER_FOR = (
+ NOT_ZERO, sub { local $^W; 0 != shift },
+ TRUE, sub { local $^W; !!shift },
+ FALSE, sub { local $^W; !shift },
+);
+
+my $can_open3 = ( $Config{d_fork} || $IsWin32 ) ? 1 : 0;
+
+for my $hide_fork ( 0 .. $can_open3 ) {
+ if ($hide_fork) {
+ no strict 'refs';
+ local $^W = 0;
+ *{'TAP::Parser::Iterator::Process::_use_open3'} = sub {return};
+ }
+
+ TEST:
+ for my $test ( sort keys %samples ) {
+
+ #next unless 'empty' eq $test;
+ my %details = %{ $samples{$test} };
+
+ if ( my $skip_if = delete $details{skip_if} ) {
+ next TEST if $skip_if->();
+ }
+
+ my $results = delete $details{results};
+ my $args = delete $details{__ARGS__};
+ my $need_open3 = delete $details{need_open3};
+
+ next TEST if $need_open3 && ( $hide_fork || !$can_open3 );
+
+ # the following acrobatics are necessary to make it easy for the
+ # Test::Builder::failure_output() method to be overridden when
+ # TAP::Parser is not installed. Otherwise, these tests will fail.
+ unshift @{ $args->{switches} }, '-It/lib';
+
+ $args->{source} = File::Spec->catfile( $SAMPLE_TESTS, $test );
+ $args->{merge} = !$hide_fork;
+
+ my $parser = eval { analyze_test( $test, [@$results], $args ) };
+ my $error = $@;
+ ok !$error, "'$test' should parse successfully" or diag $error;
+
+ if ($error) {
+ my $tests = 0;
+ while ( my ( $method, $answer ) = each %details ) {
+ $tests += ref $answer ? 2 : 1;
+ }
+ SKIP: {
+ skip "$test did not parse successfully", $tests;
+ }
+ }
+ else {
+ while ( my ( $method, $answer ) = each %details ) {
+ if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck
+ ok $handler->( $parser->$method() ),
+ "... and $method should return a reasonable value ($test)";
+ }
+ elsif ( !ref $answer ) {
+ local $^W; # uninit warnings
+
+ $answer = _vmsify_answer( $method, $answer );
+
+ is $parser->$method(), $answer,
+ "... and $method should equal $answer ($test)";
+ }
+ else {
+ is scalar $parser->$method(), scalar @$answer,
+ "... and $method should be the correct amount ($test)";
+ is_deeply [ $parser->$method() ], $answer,
+ "... and $method should be the correct values ($test)";
+ }
+ }
+ }
+ }
+}
+
+my %Unix2VMS_Exit_Codes = (
+ 1 => 4,
+);
+
+sub _vmsify_answer {
+ my ( $method, $answer ) = @_;
+
+ return $answer unless $IsVMS;
+
+ if ( $method eq 'exit'
+ and exists $Unix2VMS_Exit_Codes{$answer} )
+ {
+ $answer = $Unix2VMS_Exit_Codes{$answer};
+ }
+
+ return $answer;
+}
+
+sub analyze_test {
+ my ( $test, $results, $args ) = @_;
+
+ my $parser = TAP::Parser->new($args);
+ my $count = 1;
+ while ( defined( my $result = $parser->next ) ) {
+
+ my $expected = shift @$results;
+ my $desc
+ = $result->is_test
+ ? $result->description
+ : $result->raw;
+ $desc = $result->plan if $result->is_plan && $desc =~ /SKIP/i;
+ $desc =~ s/#/<hash>/g;
+ $desc =~ s/\s+/ /g; # Drop newlines
+ ok defined $expected,
+ "$test/$count We should have a result for $desc";
+ while ( my ( $method, $answer ) = each %$expected ) {
+
+ if ( my $handler = $HANDLER_FOR{ $answer || '' } ) { # yuck
+ ok $handler->( $result->$method() ),
+ "... and $method should return a reasonable value ($test/$count)";
+ }
+ elsif ( ref $answer ) {
+ is_deeply $result->$method(), $answer,
+ "... and $method should return the correct structure ($test/$count)";
+ }
+ else {
+ is $result->$method(), $answer,
+ "... and $method should return the correct answer ($test/$count)";
+ }
+ }
+ $count++;
+ }
+ is @$results, 0,
+ "... and we should have the correct number of results ($test)";
+ return $parser;
+}
+
+# vms_nit
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 222;
+
+use TAP::Parser::Result;
+
+use constant RESULT => 'TAP::Parser::Result';
+use constant PLAN => 'TAP::Parser::Result::Plan';
+use constant TEST => 'TAP::Parser::Result::Test';
+use constant COMMENT => 'TAP::Parser::Result::Comment';
+use constant BAILOUT => 'TAP::Parser::Result::Bailout';
+use constant UNKNOWN => 'TAP::Parser::Result::Unknown';
+
+my $warning;
+$SIG{__WARN__} = sub { $warning = shift };
+
+#
+# Note that the are basic unit tests. More comprehensive path coverage is
+# found in the regression tests.
+#
+
+my %inherited_methods = (
+ is_plan => '',
+ is_test => '',
+ is_comment => '',
+ is_bailout => '',
+ is_unknown => '',
+ is_ok => 1,
+);
+
+my $abstract_class = bless { type => 'no_such_type' },
+ RESULT; # you didn't see this
+run_method_tests( $abstract_class, {} ); # check the defaults
+
+can_ok $abstract_class, 'type';
+is $abstract_class->type, 'no_such_type',
+ '... and &type should return the correct result';
+
+can_ok $abstract_class, 'passed';
+$warning = '';
+ok $abstract_class->passed, '... and it should default to true';
+like $warning, qr/^\Qpassed() is deprecated. Please use "is_ok()"/,
+ '... but it should emit a deprecation warning';
+
+can_ok RESULT, 'new';
+eval { RESULT->new( { type => 'no_such_type' } ) };
+ok my $error = $@, '... and calling it with an unknown class should fail';
+like $error, qr/^Could not determine class for.*no_such_type/s,
+ '... with an appropriate error message';
+
+#
+# test unknown tokens
+#
+
+run_tests(
+ { class => UNKNOWN,
+ data => {
+ type => 'unknown',
+ raw => '... this line is junk ... ',
+ },
+ },
+ { is_unknown => 1,
+ raw => '... this line is junk ... ',
+ as_string => '... this line is junk ... ',
+ type => 'unknown',
+ has_directive => '',
+ }
+);
+
+#
+# test comment tokens
+#
+
+run_tests(
+ { class => COMMENT,
+ data => {
+ type => 'comment',
+ raw => '# this is a comment',
+ comment => 'this is a comment',
+ },
+ },
+ { is_comment => 1,
+ raw => '# this is a comment',
+ as_string => '# this is a comment',
+ comment => 'this is a comment',
+ type => 'comment',
+ has_directive => '',
+ }
+);
+
+#
+# test bailout tokens
+#
+
+run_tests(
+ { class => BAILOUT,
+ data => {
+ type => 'bailout',
+ raw => 'Bailout! This blows!',
+ bailout => 'This blows!',
+ },
+ },
+ { is_bailout => 1,
+ raw => 'Bailout! This blows!',
+ as_string => 'This blows!',
+ type => 'bailout',
+ has_directive => '',
+ }
+);
+
+#
+# test plan tokens
+#
+
+run_tests(
+ { class => PLAN,
+ data => {
+ type => 'plan',
+ raw => '1..20',
+ tests_planned => 20,
+ directive => '',
+ explanation => '',
+ },
+ },
+ { is_plan => 1,
+ raw => '1..20',
+ tests_planned => 20,
+ directive => '',
+ explanation => '',
+ has_directive => '',
+ }
+);
+
+run_tests(
+ { class => PLAN,
+ data => {
+ type => 'plan',
+ raw => '1..0 # SKIP help me, Rhonda!',
+ tests_planned => 0,
+ directive => 'SKIP',
+ explanation => 'help me, Rhonda!',
+ },
+ },
+ { is_plan => 1,
+ raw => '1..0 # SKIP help me, Rhonda!',
+ tests_planned => 0,
+ directive => 'SKIP',
+ explanation => 'help me, Rhonda!',
+ has_directive => 1,
+ }
+);
+
+#
+# test 'test' tokens
+#
+
+my $test = run_tests(
+ { class => TEST,
+ data => {
+ ok => 'ok',
+ test_num => 5,
+ description => '... and this test is fine',
+ directive => '',
+ explanation => '',
+ raw => 'ok 5 and this test is fine',
+ type => 'test',
+ },
+ },
+ { is_test => 1,
+ type => 'test',
+ ok => 'ok',
+ number => 5,
+ description => '... and this test is fine',
+ directive => '',
+ explanation => '',
+ is_ok => 1,
+ is_actual_ok => 1,
+ todo_passed => '',
+ has_skip => '',
+ has_todo => '',
+ as_string => 'ok 5 ... and this test is fine',
+ is_unplanned => '',
+ has_directive => '',
+ }
+);
+
+can_ok $test, 'actual_passed';
+$warning = '';
+is $test->actual_passed, $test->is_actual_ok,
+ '... and it should return the correct value';
+like $warning,
+ qr/^\Qactual_passed() is deprecated. Please use "is_actual_ok()"/,
+ '... but issue a deprecation warning';
+
+can_ok $test, 'todo_failed';
+$warning = '';
+is $test->todo_failed, $test->todo_passed,
+ '... and it should return the correct value';
+like $warning,
+ qr/^\Qtodo_failed() is deprecated. Please use "todo_passed()"/,
+ '... but issue a deprecation warning';
+
+# TODO directive
+
+$test = run_tests(
+ { class => TEST,
+ data => {
+ ok => 'not ok',
+ test_num => 5,
+ description => '... and this test is fine',
+ directive => 'TODO',
+ explanation => 'why not?',
+ raw => 'not ok 5 and this test is fine # TODO why not?',
+ type => 'test',
+ },
+ },
+ { is_test => 1,
+ type => 'test',
+ ok => 'not ok',
+ number => 5,
+ description => '... and this test is fine',
+ directive => 'TODO',
+ explanation => 'why not?',
+ is_ok => 1,
+ is_actual_ok => '',
+ todo_passed => '',
+ has_skip => '',
+ has_todo => 1,
+ as_string =>
+ 'not ok 5 ... and this test is fine # TODO why not?',
+ is_unplanned => '',
+ has_directive => 1,
+ }
+);
+
+sub run_tests {
+ my ( $instantiated, $value_for ) = @_;
+ my $result = instantiate($instantiated);
+ run_method_tests( $result, $value_for );
+ return $result;
+}
+
+sub instantiate {
+ my $instantiated = shift;
+ my $class = $instantiated->{class};
+ ok my $result = RESULT->new( $instantiated->{data} ),
+ 'Creating $class results should succeed';
+ isa_ok $result, $class, '.. and the object it returns';
+ return $result;
+}
+
+sub run_method_tests {
+ my ( $result, $value_for ) = @_;
+ while ( my ( $method, $default ) = each %inherited_methods ) {
+ can_ok $result, $method;
+ if ( defined( my $value = delete $value_for->{$method} ) ) {
+ is $result->$method(), $value,
+ "... and $method should be correct";
+ }
+ else {
+ is $result->$method(), $default,
+ "... and $method default should be correct";
+ }
+ }
+ while ( my ( $method, $value ) = each %$value_for ) {
+ can_ok $result, $method;
+ is $result->$method(), $value, "... and $method should be correct";
+ }
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip pending resolution of how to set the library with -I\n";
+ exit 0;
+ }
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 30;
+
+use File::Spec;
+
+use TAP::Parser::Source;
+use TAP::Parser::Source::Perl;
+
+my $test = File::Spec->catfile( $ENV{PERL_CORE} ? 'lib' : 't', 'source_tests',
+ 'source' );
+
+my $perl = $^X;
+
+can_ok 'TAP::Parser::Source', 'new';
+my $source = TAP::Parser::Source->new;
+isa_ok $source, 'TAP::Parser::Source';
+
+can_ok $source, 'source';
+eval { $source->source("$perl -It/lib $test") };
+ok my $error = $@, '... and calling it with a string should fail';
+like $error, qr/^Argument to &source must be an array reference/,
+ '... with an appropriate error message';
+ok $source->source( [ $perl, '-It/lib', '-T', $test ] ),
+ '... and calling it with valid args should succeed';
+
+can_ok $source, 'get_stream';
+my $stream = $source->get_stream;
+
+isa_ok $stream, 'TAP::Parser::Iterator::Process',
+ 'get_stream returns the right object';
+can_ok $stream, 'next';
+is $stream->next, '1..1', '... and the first line should be correct';
+is $stream->next, 'ok 1', '... as should the second';
+ok !$stream->next, '... and we should have no more results';
+
+can_ok 'TAP::Parser::Source::Perl', 'new';
+$source = TAP::Parser::Source::Perl->new;
+isa_ok $source, 'TAP::Parser::Source::Perl', '... and the object it returns';
+
+can_ok $source, 'source';
+ok $source->source( [$test] ),
+ '... and calling it with valid args should succeed';
+
+can_ok $source, 'get_stream';
+$stream = $source->get_stream;
+
+isa_ok $stream, 'TAP::Parser::Iterator::Process',
+ '... and the object it returns';
+can_ok $stream, 'next';
+is $stream->next, '1..1', '... and the first line should be correct';
+is $stream->next, 'ok 1', '... as should the second';
+ok !$stream->next, '... and we should have no more results';
+
+# internals tests!
+
+can_ok $source, '_switches';
+ok( grep( $_ =~ /^['"]?-T['"]?$/, $source->_switches ),
+ '... and it should find the taint switch'
+);
+
+# coverage test for TAP::PArser::Source
+
+{
+
+ # coverage for method get_steam
+
+ my $source = TAP::Parser::Source->new();
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ $source->get_stream;
+ };
+
+ is @die, 1, 'coverage testing of get_stream';
+
+ like pop @die, qr/No command found!/, '...and it failed as expect';
+}
+
+{
+
+ # coverage testing for error
+
+ my $source = TAP::Parser::Source->new();
+
+ my $error = $source->error;
+
+ is $error, undef, 'coverage testing for error()';
+
+ $source->error('save me');
+
+ $error = $source->error;
+
+ is $error, 'save me', '...and we got the expected message';
+}
+
+{
+
+ # coverage testing for exit
+
+ my $source = TAP::Parser::Source->new();
+
+ my $exit = $source->exit;
+
+ is $exit, undef, 'coverage testing for exit()';
+
+ $source->exit('save me');
+
+ $exit = $source->exit;
+
+ is $exit, 'save me', '...and we got the expected message';
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip pending resolution of how to avoid creating a directory t in the core\n";
+ exit 0;
+ }
+}
+
+# test T::H::_open_spool and _close_spool - these are good examples
+# of the 'Fragile Test' pattern - messing with I/O primitives breaks
+# nearly everything
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+
+my $useOrigOpen;
+my $useOrigClose;
+
+# setup replacements for core open and close - breaking these makes everything very fragile
+BEGIN {
+ $useOrigOpen = $useOrigClose = 1;
+
+ # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2
+
+ *CORE::GLOBAL::open = \&my_open;
+
+ sub my_open (*@) {
+ if ($useOrigOpen) {
+ if ( defined( $_[0] ) ) {
+ use Symbol qw();
+ my $handle = Symbol::qualify( $_[0], (caller)[0] );
+ no strict 'refs';
+ if ( @_ == 1 ) {
+ return CORE::open($handle);
+ }
+ elsif ( @_ == 2 ) {
+ return CORE::open( $handle, $_[1] );
+ }
+ else {
+ die "Can't open with more than two args";
+ }
+ }
+ }
+ else {
+ return;
+ }
+ }
+
+ *CORE::GLOBAL::close = sub (*) {
+ if ($useOrigClose) { return CORE::close(shift) }
+ else {return}
+ };
+
+}
+
+use TAP::Harness;
+use TAP::Parser;
+
+plan tests => 4;
+
+{
+
+ # coverage tests for the basically untested T::H::_open_spool
+
+ $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool));
+
+# now given that we're going to be writing stuff to the file system, make sure we have
+# a cleanup hook
+
+ END {
+ use File::Path;
+
+ $useOrigOpen = $useOrigClose = 1;
+
+ # remove the tree if we made it this far
+ rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
+ if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
+ }
+
+ my @die;
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ # use the broken open
+ $useOrigOpen = 0;
+
+ TAP::Harness->_open_spool(
+ File::Spec->catfile(qw (source_tests harness )) );
+
+ # restore universal sanity
+ $useOrigOpen = 1;
+ };
+
+ is @die, 1, 'open failed, die as expected';
+
+ my $spoolDir
+ = quotemeta( File::Spec->catfile(qw( t spool source_tests harness )) );
+
+ like pop @die, qr/ Can't write $spoolDir [(] /,
+ '...with expected message';
+
+ # now make close fail
+
+ use Symbol;
+
+ my $spoolHandle = gensym;
+
+ my $tap = <<'END_TAP';
+1..1
+ok 1 - input file opened
+
+END_TAP
+
+ my $parser = TAP::Parser->new(
+ { spool => $spoolHandle,
+ stream => TAP::Parser::Iterator->new( [ split /\n/ => $tap ] )
+ }
+ );
+
+ @die = ();
+
+ eval {
+ local $SIG{__DIE__} = sub { push @die, @_ };
+
+ # use the broken CORE::close
+ $useOrigClose = 0;
+
+ TAP::Harness->_close_spool($parser);
+
+ $useOrigClose = 1;
+ };
+
+ unless ( is @die, 1, 'close failed, die as expected' ) {
+ diag " >>> $_ <<<\n" for @die;
+ }
+
+ like pop @die, qr/ Error closing TAP spool file[(] /,
+ '...with expected message';
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+use App::Prove::State;
+
+my @schedule = (
+
+ # last => sub {
+ # failed => sub {
+ # passed => sub {
+ # all => sub {
+ # todo => sub {
+ # hot => sub {
+ # save => sub {
+ # adrian => sub {
+ { options => 'all',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'failed',
+ get_tests_args => [],
+ expect => [
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ ],
+ },
+ { options => 'passed',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'last',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'todo',
+ get_tests_args => [],
+ expect => [
+ 't/compat/version.t',
+ 't/compat/failure.t',
+ ],
+
+ },
+ { options => 'hot',
+ get_tests_args => [],
+ expect => [
+ 't/compat/version.t',
+ 't/yamlish-writer.t',
+ 't/compat/env.t',
+ ],
+ },
+ { options => 'adrian',
+ get_tests_args => [],
+ expect => [
+ 't/compat/version.t',
+ 't/yamlish-writer.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'failed,passed',
+ get_tests_args => [],
+ expect => [
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => [ 'failed', 'passed' ],
+ get_tests_args => [],
+ expect => [
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'slow',
+ get_tests_args => [],
+ expect => [
+ 't/yamlish-writer.t',
+ 't/compat/env.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/failure.t',
+ 't/source.t',
+ ],
+ },
+ { options => 'fast',
+ get_tests_args => [],
+ expect => [
+ 't/source.t',
+ 't/compat/failure.t',
+ 't/compat/version.t',
+ 't/compat/inc_taint.t',
+ 't/compat/env.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'old',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/source.t',
+ 't/yamlish-writer.t',
+ ],
+ },
+ { options => 'new',
+ get_tests_args => [],
+ expect => [
+ 't/source.t',
+ 't/yamlish-writer.t',
+ 't/compat/inc_taint.t',
+ 't/compat/version.t',
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ ],
+ },
+);
+
+plan tests => @schedule * 2;
+
+for my $test (@schedule) {
+ my $state = App::Prove::State->new;
+ isa_ok $state, 'App::Prove::State';
+
+ my $desc = $test->{options};
+
+ # Naughty
+ $state->{_} = get_state();
+ my $options = $test->{options};
+ $options = [$options] unless 'ARRAY' eq ref $options;
+ $state->apply_switch(@$options);
+
+ my @got = $state->get_tests( @{ $test->{get_tests_args} } );
+
+ unless ( is_deeply \@got, $test->{expect}, "$desc: order OK" ) {
+ use Data::Dumper;
+ diag( Dumper( { got => \@got, want => $test->{expect} } ) );
+ }
+}
+
+sub get_state {
+ return {
+ 'generation' => '51',
+ 'tests' => {
+ 't/compat/failure.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371471.57738',
+ 'last_pass_time' => '1196371471.57738',
+ 'total_passes' => '48',
+ 'seq' => '1549',
+ 'gen' => '51',
+ 'elapsed' => 0.1230,
+ 'last_todo' => '1'
+ },
+ 't/yamlish-writer.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371480.5761',
+ 'last_pass_time' => '1196371480.5761',
+ 'last_fail_time' => '1196368609',
+ 'total_passes' => '41',
+ 'seq' => '1578',
+ 'gen' => '49',
+ 'elapsed' => 12.2983,
+ 'last_todo' => '0'
+ },
+ 't/compat/env.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371471.42967',
+ 'last_pass_time' => '1196371471.42967',
+ 'last_fail_time' => '1196368608',
+ 'total_passes' => '48',
+ 'seq' => '1548',
+ 'gen' => '52',
+ 'elapsed' => 3.1290,
+ 'last_todo' => '0'
+ },
+ 't/compat/version.t' => {
+ 'last_result' => '2',
+ 'last_run_time' => '1196371472.96476',
+ 'last_pass_time' => '1196371472.96476',
+ 'last_fail_time' => '1196368609',
+ 'total_passes' => '47',
+ 'seq' => '1555',
+ 'gen' => '51',
+ 'elapsed' => 0.2363,
+ 'last_todo' => '4'
+ },
+ 't/compat/inc_taint.t' => {
+ 'last_result' => '3',
+ 'last_run_time' => '1196371471.89682',
+ 'last_pass_time' => '1196371471.89682',
+ 'total_passes' => '47',
+ 'seq' => '1551',
+ 'gen' => '51',
+ 'elapsed' => 1.6938,
+ 'last_todo' => '0'
+ },
+ 't/source.t' => {
+ 'last_result' => '0',
+ 'last_run_time' => '1196371479.72508',
+ 'last_pass_time' => '1196371479.72508',
+ 'total_passes' => '41',
+ 'seq' => '1570',
+ 'gen' => '51',
+ 'elapsed' => 0.0143,
+ 'last_todo' => '0'
+ },
+ }
+ };
+}
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 47;
+
+use TAP::Parser;
+use TAP::Parser::Iterator;
+
+my ( $STREAMED, $ITER ) = ( 'TAP::Parser', 'TAP::Parser::Iterator' );
+my $ITER_FH = "${ITER}::Stream";
+my $ITER_ARRAY = "${ITER}::Array";
+
+my $stream = TAP::Parser::Iterator->new( \*DATA );
+isa_ok $stream, 'TAP::Parser::Iterator';
+my $parser = TAP::Parser->new( { stream => $stream } );
+isa_ok $parser, 'TAP::Parser',
+ '... and creating a streamed parser should succeed';
+
+can_ok $parser, '_stream';
+is ref $parser->_stream, $ITER_FH,
+ '... and it should return the proper iterator';
+can_ok $parser, 'next';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+
+ok !$parser->parse_errors, '... and we should have no parse errors';
+
+# plan at end
+
+my $tap = <<'END_TAP';
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+1..5
+END_TAP
+
+$stream = $ITER->new( [ split /\n/ => $tap ] );
+ok $parser = TAP::Parser->new( { stream => $stream } ),
+ 'Now we create a parser with the plan at the end';
+isa_ok $parser->_stream, $ITER_ARRAY,
+ '... and now we should have an array iterator';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+
+ok !$parser->parse_errors, '... and we should have no parse errors';
+
+# misplaced plan (and one-off errors)
+
+$tap = <<'END_TAP';
+ok 1 - input file opened
+1..5
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
+END_TAP
+
+$stream = $ITER->new( [ split /\n/ => $tap ] );
+
+ok $parser = TAP::Parser->new( { stream => $stream } ),
+ 'Now we create a parser with a plan as the second line';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+
+ok $parser->parse_errors, '... and we should have one parse error';
+is + ( $parser->parse_errors )[0],
+ 'Plan (1..5) must be at the beginning or end of the TAP output',
+ '... telling us that our plan went awry';
+
+$tap = <<'END_TAP';
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+1..5
+ok 5 # skip we have no description
+END_TAP
+
+$stream = $ITER->new( [ split /\n/ => $tap ] );
+
+ok $parser = TAP::Parser->new( { stream => $stream } ),
+ 'Now we create a parser with the plan as the second to last line';
+is $parser->next->as_string, 'ok 1 - input file opened',
+ '... and the first test should parse correctly';
+is $parser->next->as_string, '... this is junk',
+ '... and junk should parse correctly';
+is $parser->next->as_string,
+ 'not ok 2 first line of the input valid # TODO some data',
+ '... and the second test should parse correctly';
+is $parser->next->as_string, '# this is a comment',
+ '... and comments should parse correctly';
+is $parser->next->as_string, 'ok 3 - read the rest of the file',
+ '... and the third test should parse correctly';
+is $parser->next->as_string, 'not ok 4 - this is a real failure',
+ '... and the fourth test should parse correctly';
+is $parser->next->as_string, '1..5',
+ '... and the plan should parse correctly';
+is $parser->next->as_string, 'ok 5 # SKIP we have no description',
+ '... and fifth test should parse correctly';
+
+ok $parser->parse_errors, '... and we should have one parse error';
+is + ( $parser->parse_errors )[0],
+ 'Plan (1..5) must be at the beginning or end of the TAP output',
+ '... telling us that our plan went awry';
+
+__DATA__
+1..5
+ok 1 - input file opened
+... this is junk
+not ok first line of the input valid # todo some data
+# this is a comment
+ok 3 - read the rest of the file
+not ok 4 - this is a real failure
+ok 5 # skip we have no description
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ if ($ENV{PERL_CORE}) {
+ # FIXME
+ print "1..0 # Skip pending resolution of how to set the library with -I\n";
+ exit 0;
+ }
+}
+
+# Test that options in PERL5LIB and PERL5OPT are propogated to tainted
+# tests
+
+use strict;
+use lib 't/lib';
+
+use Test::More ( $^O eq 'VMS' ? ( skip_all => 'VMS' ) : ( tests => 3 ) );
+
+use Config;
+use TAP::Parser;
+
+sub run_test_file {
+ my ( $test_template, @args ) = @_;
+
+ my $test_file = 't/temp_test.tmp';
+
+ open TEST, ">$test_file" or die $!;
+ printf TEST $test_template, @args;
+ close TEST;
+
+ my $p = TAP::Parser->new( { source => $test_file } );
+ 1 while $p->next;
+ ok !$p->has_problems;
+
+ unlink $test_file;
+}
+
+{
+ local $ENV{PERL5LIB} = join $Config{path_sep}, grep defined, 'wibble',
+ $ENV{PERL5LIB};
+ run_test_file(<<'END');
+#!/usr/bin/perl -T
+
+use lib 't/lib';
+use Test::More tests => 1;
+
+is( $INC[1], 'wibble' ) or diag join "\n", @INC;
+END
+}
+
+{
+ my $perl5lib = $ENV{PERL5LIB};
+ local $ENV{PERL5LIB};
+ local $ENV{PERLLIB} = join $Config{path_sep}, grep defined, 'wibble',
+ $perl5lib;
+ run_test_file(<<'END');
+#!/usr/bin/perl -T
+
+use lib 't/lib';
+use Test::More tests => 1;
+
+is( $INC[1], 'wibble' ) or diag join "\n", @INC;
+END
+}
+
+{
+ local $ENV{PERL5OPT} = '-Mstrict';
+ run_test_file(<<'END');
+#!/usr/bin/perl -T
+
+print "1..1\n";
+print $INC{'strict.pm'} ? "ok 1\n" : "not ok 1\n";
+END
+}
+
+1;
--- /dev/null
+#!/usr/bin/perl -w
+
+BEGIN {
+ chdir 't' and @INC = '../lib' if $ENV{PERL_CORE};
+}
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 19;
+use File::Spec;
+use TAP::Parser;
+use TAP::Harness;
+use App::Prove;
+
+my $test = File::Spec->catfile( ($ENV{PERL_CORE} ? 'lib' : 't'),
+ 'sample-tests', 'echo' );
+
+diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV;
+
+sub echo_ok {
+ my $options = shift;
+ my @args = @_;
+ my $parser = TAP::Parser->new( { %$options, test_args => \@args } );
+ my @got = ();
+ while ( my $result = $parser->next ) {
+ push @got, $result;
+ }
+ my $plan = shift @got;
+ ok $plan->is_plan;
+ for (@got) {
+ is $_->description, shift(@args),
+ join( ', ', keys %$options ) . ": option passed OK";
+ }
+}
+
+for my $args ( [qw( yes no maybe )], [qw( 1 2 3 )] ) {
+ echo_ok( { source => $test }, @$args );
+ echo_ok( { exec => [ $^X, $test ] }, @$args );
+}
+
+{
+ my $harness = TAP::Harness->new(
+ { verbosity => -9, test_args => [qw( magic hat brigade )] } );
+ my $aggregate = $harness->runtests($test);
+
+ is $aggregate->total, 3, "ran the right number of tests";
+ is $aggregate->passed, 3, "and they passed";
+}
+
+package Test::Prove;
+
+use vars qw(@ISA);
+@ISA = 'App::Prove';
+
+sub _runtests {
+ my $self = shift;
+ push @{ $self->{_log} }, [@_];
+ return;
+}
+
+sub get_run_log {
+ my $self = shift;
+ return $self->{_log};
+}
+
+package main;
+
+{
+ my $app = Test::Prove->new;
+
+ $app->process_args( '--norc', $test, '::', 'one', 'two', 'huh' );
+ $app->run();
+ my $log = $app->get_run_log;
+ is_deeply $log->[0]->[0]->{test_args}, [ 'one', 'two', 'huh' ],
+ "prove args match";
+}
+
+sub bigness {
+ my $str = join '', @_;
+ my @cdef = (
+ '0000000000000000', '1818181818001800', '6c6c6c0000000000',
+ '36367f367f363600', '0c3f683e0b7e1800', '60660c1830660600',
+ '386c6c386d663b00', '0c18300000000000', '0c18303030180c00',
+ '30180c0c0c183000', '00187e3c7e180000', '0018187e18180000',
+ '0000000000181830', '0000007e00000000', '0000000000181800',
+ '00060c1830600000', '3c666e7e76663c00', '1838181818187e00',
+ '3c66060c18307e00', '3c66061c06663c00', '0c1c3c6c7e0c0c00',
+ '7e607c0606663c00', '1c30607c66663c00', '7e060c1830303000',
+ '3c66663c66663c00', '3c66663e060c3800', '0000181800181800',
+ '0000181800181830', '0c18306030180c00', '00007e007e000000',
+ '30180c060c183000', '3c660c1818001800', '3c666e6a6e603c00',
+ '3c66667e66666600', '7c66667c66667c00', '3c66606060663c00',
+ '786c6666666c7800', '7e60607c60607e00', '7e60607c60606000',
+ '3c66606e66663c00', '6666667e66666600', '7e18181818187e00',
+ '3e0c0c0c0c6c3800', '666c7870786c6600', '6060606060607e00',
+ '63777f6b6b636300', '6666767e6e666600', '3c66666666663c00',
+ '7c66667c60606000', '3c6666666a6c3600', '7c66667c6c666600',
+ '3c66603c06663c00', '7e18181818181800', '6666666666663c00',
+ '66666666663c1800', '63636b6b7f776300', '66663c183c666600',
+ '6666663c18181800', '7e060c1830607e00', '7c60606060607c00',
+ '006030180c060000', '3e06060606063e00', '183c664200000000',
+ '00000000000000ff', '1c36307c30307e00', '00003c063e663e00',
+ '60607c6666667c00', '00003c6660663c00', '06063e6666663e00',
+ '00003c667e603c00', '1c30307c30303000', '00003e66663e063c',
+ '60607c6666666600', '1800381818183c00', '1800381818181870',
+ '6060666c786c6600', '3818181818183c00', '0000367f6b6b6300',
+ '00007c6666666600', '00003c6666663c00', '00007c66667c6060',
+ '00003e66663e0607', '00006c7660606000', '00003e603c067c00',
+ '30307c3030301c00', '0000666666663e00', '00006666663c1800',
+ '0000636b6b7f3600', '0000663c183c6600', '00006666663e063c',
+ '00007e0c18307e00', '0c18187018180c00', '1818180018181800',
+ '3018180e18183000', '316b460000000000'
+ );
+ my @chars = unpack( 'C*', $str );
+ my @out = ();
+ for my $row ( 0 .. 7 ) {
+ for my $char (@chars) {
+ next if $char < 32 || $char > 126;
+ my $size = scalar(@cdef);
+ my $byte = hex( substr( $cdef[ $char - 32 ], $row * 2, 2 ) );
+ my $bits = sprintf( '%08b', $byte );
+ $bits =~ tr/01/ #/;
+ push @out, $bits;
+ }
+ push @out, "\n";
+ }
+ return join '', @out;
+}
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+use Test::More;
+use TAP::Parser;
+
+my @schedule;
+my %make_test;
+
+BEGIN {
+ plan skip_all => "unicode on Perl < 5.8.0"
+ unless $] > 5.008;
+
+ eval "use File::Temp";
+ plan skip_all => "File::Temp unavailable"
+ if $@;
+
+ eval "use Encode";
+ plan skip_all => "Encode unavailable"
+ if $@;
+
+ # Subs that take the supplied TAP and turn it into a set of args to
+ # supply to TAP::Harness->new. The returned hash includes the
+ # temporary file so that its reference count doesn't go to zero
+ # until we're finished with it.
+ %make_test = (
+ file => sub {
+ my $source = shift;
+ my $tmp = File::Temp->new;
+ open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n";
+ eval 'binmode( $fh, ":utf8" )';
+ print $fh join( "\n", @$source ), "\n";
+ close $fh;
+
+ open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n";
+ eval 'binmode( $taph, ":utf8" )';
+ return {
+ temp => $tmp,
+ args => { source => $taph },
+ };
+ },
+ script => sub {
+ my $source = shift;
+ my $tmp = File::Temp->new;
+ open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n";
+ eval 'binmode( $fh, ":utf8" )';
+ print $fh map {"print qq{$_\\n};\n"} @$source;
+ close $fh;
+
+ open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n";
+ return {
+ temp => $tmp,
+ args => { exec => [ $^X, "$tmp" ] },
+ };
+ },
+ );
+
+ @schedule = (
+ { name => 'Non-unicode warm up',
+ source => [
+ 'TAP version 13',
+ '1..1',
+ 'ok 1 Everything is fine',
+ ],
+ expect => [
+ { isa => 'TAP::Parser::Result::Version', },
+ { isa => 'TAP::Parser::Result::Plan', },
+ { isa => 'TAP::Parser::Result::Test',
+ description => "Everything is fine"
+ },
+ ],
+ },
+ { name => 'Unicode smiley',
+ source => [
+ 'TAP version 13',
+ '1..1',
+
+ # Funky quoting / eval to avoid errors on older Perls
+ eval qq{"ok 1 Everything is fine \\x{263a}"},
+ ],
+ expect => [
+ { isa => 'TAP::Parser::Result::Version', },
+ { isa => 'TAP::Parser::Result::Plan', },
+ { isa => 'TAP::Parser::Result::Test',
+ description => eval qq{"Everything is fine \\x{263a}"}
+ },
+ ],
+ }
+ );
+
+ plan 'no_plan';
+}
+
+for my $test (@schedule) {
+ for my $type ( sort keys %make_test ) {
+ my $name = sprintf( "%s (%s)", $test->{name}, $type );
+ my $args = $make_test{$type}->( $test->{source} );
+
+ my $parser = TAP::Parser->new( $args->{args} );
+ isa_ok $parser, 'TAP::Parser';
+ my @expect = @{ $test->{expect} };
+ while ( my $tok = $parser->next ) {
+ my $exp = shift @expect;
+ for my $item ( sort keys %$exp ) {
+ my $val = $exp->{$item};
+ if ( 'isa' eq $item ) {
+ isa_ok $tok, $val;
+ }
+ elsif ( 'CODE' eq ref $val ) {
+ ok $val->($tok), "$name: assertion for $item";
+ }
+ else {
+ my $got = $tok->$item();
+ is $got, $val, "$name: value for $item matches";
+ }
+ }
+ }
+ }
+}
--- /dev/null
+#!/usr/bin/perl -wT
+
+use strict;
+use lib 't/lib';
+
+use Test::More tests => 9;
+
+use TAP::Parser::YAMLish::Writer;
+
+my $out = [
+ "---",
+ "bill-to:",
+ " address:",
+ " city: \"Royal Oak\"",
+ " lines: \"458 Walkman Dr.\\nSuite #292\\n\"",
+ " postal: 48046",
+ " state: MI",
+ " family: Dumars",
+ " given: Chris",
+ "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"",
+ "date: 2001-01-23",
+ "invoice: 34843",
+ "product:",
+ " -",
+ " description: Basketball",
+ " price: 450.00",
+ " quantity: 4",
+ " sku: BL394D",
+ " -",
+ " description: \"Super Hoop\"",
+ " price: 2392.00",
+ " quantity: 1",
+ " sku: BL4438H",
+ "tax: 251.42",
+ "total: 4443.52",
+ "...",
+];
+
+my $in = {
+ 'bill-to' => {
+ 'given' => 'Chris',
+ 'address' => {
+ 'city' => 'Royal Oak',
+ 'postal' => '48046',
+ 'lines' => "458 Walkman Dr.\nSuite #292\n",
+ 'state' => 'MI'
+ },
+ 'family' => 'Dumars'
+ },
+ 'invoice' => '34843',
+ 'date' => '2001-01-23',
+ 'tax' => '251.42',
+ 'product' => [
+ { 'sku' => 'BL394D',
+ 'quantity' => '4',
+ 'price' => '450.00',
+ 'description' => 'Basketball'
+ },
+ { 'sku' => 'BL4438H',
+ 'quantity' => '1',
+ 'price' => '2392.00',
+ 'description' => 'Super Hoop'
+ }
+ ],
+ 'comments' =>
+ "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n",
+ 'total' => '4443.52'
+};
+
+my @buf1 = ();
+my @buf2 = ();
+my $buf3 = '';
+
+my @destination = (
+ { name => 'Array reference',
+ destination => \@buf1,
+ normalise => sub { return \@buf1 },
+ },
+ { name => 'Closure',
+ destination => sub { push @buf2, shift },
+ normalise => sub { return \@buf2 },
+ },
+ { name => 'Scalar',
+ destination => \$buf3,
+ normalise => sub {
+ my @ar = split( /\n/, $buf3 );
+ return \@ar;
+ },
+ },
+);
+
+for my $dest (@destination) {
+ my $name = $dest->{name};
+ ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created";
+ isa_ok $yaml, 'TAP::Parser::YAMLish::Writer';
+
+ $yaml->write( $in, $dest->{destination} );
+ my $got = $dest->{normalise}->();
+ is_deeply $got, $out, "$name: Result matches";
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+
+use TAP::Parser::YAMLish::Reader;
+use TAP::Parser::YAMLish::Writer;
+
+my @SCHEDULE;
+
+BEGIN {
+ @SCHEDULE = (
+ { name => 'Simple scalar',
+ in => 1,
+ out => [
+ '--- 1',
+ '...',
+ ],
+ },
+ { name => 'Undef',
+ in => undef,
+ out => [
+ '--- ~',
+ '...',
+ ],
+ },
+ { name => 'Unprintable',
+ in => "\x01\n\t",
+ out => [
+ '--- "\x01\n\t"',
+ '...',
+ ],
+ },
+ { name => 'Simple array',
+ in => [ 1, 2, 3 ],
+ out => [
+ '---',
+ '- 1',
+ '- 2',
+ '- 3',
+ '...',
+ ],
+ },
+ { name => 'Empty array',
+ in => [],
+ out => [
+ '--- []',
+ '...'
+ ],
+ },
+ { name => 'Empty hash',
+ in => {},
+ out => [
+ '--- {}',
+ '...'
+ ],
+ },
+ { name => 'Array, two elements, undef',
+ in => [ undef, undef ],
+ out => [
+ '---',
+ '- ~',
+ '- ~',
+ '...',
+ ],
+ },
+ { name => 'Nested array',
+ in => [ 1, 2, [ 3, 4 ], 5 ],
+ out => [
+ '---',
+ '- 1',
+ '- 2',
+ '-',
+ ' - 3',
+ ' - 4',
+ '- 5',
+ '...',
+ ],
+ },
+ { name => 'Nested empty',
+ in => [ 1, 2, [], 5 ],
+ out => [
+ '---',
+ '- 1',
+ '- 2',
+ '- []',
+ '- 5',
+ '...',
+ ],
+ },
+ { name => 'Simple hash',
+ in => { one => '1', two => '2', three => '3' },
+ out => [
+ '---',
+ 'one: 1',
+ 'three: 3',
+ 'two: 2',
+ '...',
+ ],
+ },
+ { name => 'Nested hash',
+ in => {
+ one => '1', two => '2',
+ more => { three => '3', four => '4' }
+ },
+ out => [
+ '---',
+ 'more:',
+ ' four: 4',
+ ' three: 3',
+ 'one: 1',
+ 'two: 2',
+ '...',
+ ],
+ },
+ { name => 'Nested empty',
+ in => { one => '1', two => '2', more => {} },
+ out => [
+ '---',
+ 'more: {}',
+ 'one: 1',
+ 'two: 2',
+ '...',
+ ],
+ },
+ { name => 'Unprintable key',
+ in => { one => '1', "\x02" => '2', three => '3' },
+ out => [
+ '---',
+ '"\x02": 2',
+ 'one: 1',
+ 'three: 3',
+ '...',
+ ],
+ },
+ { name => 'Empty key',
+ in => { '' => 'empty' },
+ out => [
+ '---',
+ "'': empty",
+ '...',
+ ],
+ },
+ { name => 'Empty value',
+ in => { '' => '' },
+ out => [
+ '---',
+ "'': ''",
+ '...',
+ ],
+ },
+ { name => 'Complex',
+ in => {
+ 'bill-to' => {
+ 'given' => 'Chris',
+ 'address' => {
+ 'city' => 'Royal Oak',
+ 'postal' => '48046',
+ 'lines' => "458 Walkman Dr.\nSuite #292\n",
+ 'state' => 'MI'
+ },
+ 'family' => 'Dumars'
+ },
+ 'invoice' => '34843',
+ 'date' => '2001-01-23',
+ 'tax' => '251.42',
+ 'product' => [
+ { 'sku' => 'BL394D',
+ 'quantity' => '4',
+ 'price' => '450.00',
+ 'description' => 'Basketball'
+ },
+ { 'sku' => 'BL4438H',
+ 'quantity' => '1',
+ 'price' => '2392.00',
+ 'description' => 'Super Hoop'
+ }
+ ],
+ 'comments' =>
+ "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n",
+ 'total' => '4443.52'
+ },
+ out => [
+ "---",
+ "bill-to:",
+ " address:",
+ " city: \"Royal Oak\"",
+ " lines: \"458 Walkman Dr.\\nSuite #292\\n\"",
+ " postal: 48046",
+ " state: MI",
+ " family: Dumars",
+ " given: Chris",
+ "comments: \"Late afternoon is best. Backup contact is Nancy Billsmer \@ 338-4338\\n\"",
+ "date: 2001-01-23",
+ "invoice: 34843",
+ "product:",
+ " -",
+ " description: Basketball",
+ " price: 450.00",
+ " quantity: 4",
+ " sku: BL394D",
+ " -",
+ " description: \"Super Hoop\"",
+ " price: 2392.00",
+ " quantity: 1",
+ " sku: BL4438H",
+ "tax: 251.42",
+ "total: 4443.52",
+ "...",
+ ],
+ },
+ );
+
+ plan tests => @SCHEDULE * 6;
+}
+
+sub iter {
+ my $ar = shift;
+ return sub {
+ return shift @$ar;
+ };
+}
+
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+ ok my $yaml = TAP::Parser::YAMLish::Writer->new, "$name: Created";
+ isa_ok $yaml, 'TAP::Parser::YAMLish::Writer';
+
+ my $got = [];
+ my $writer = sub { push @$got, shift };
+
+ my $data = $test->{in};
+
+ eval { $yaml->write( $data, $writer ) };
+
+ if ( my $err = $test->{error} ) {
+ unless ( like $@, $err, "$name: Error message" ) {
+ diag "Error: $@\n";
+ }
+ is_deeply $got, [], "$name: No result";
+ pass;
+ }
+ else {
+ my $want = $test->{out};
+ unless ( ok !$@, "$name: No error" ) {
+ diag "Error: $@\n";
+ }
+ unless ( is_deeply $got, $want, "$name: Result matches" ) {
+ use Data::Dumper;
+ diag Dumper($got);
+ diag Dumper($want);
+ }
+
+ my $yr = TAP::Parser::YAMLish::Reader->new;
+
+ # Now try parsing it
+ my $reader = sub { shift @$got };
+ my $parsed = eval { $yr->read($reader) };
+ ok !$@, "$name: no error" or diag "$@";
+
+ is_deeply $parsed, $data, "$name: Reparse OK";
+ }
+}
+
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use lib 't/lib';
+
+use Test::More;
+
+use TAP::Parser::YAMLish::Reader;
+
+my @SCHEDULE;
+
+BEGIN {
+ @SCHEDULE = (
+ { name => 'Hello World',
+ in => [
+ '--- Hello, World',
+ '...',
+ ],
+ out => "Hello, World",
+ },
+ { name => 'Hello World 2',
+ in => [
+ '--- \'Hello, \'\'World\'',
+ '...',
+ ],
+ out => "Hello, 'World",
+ },
+ { name => 'Hello World 3',
+ in => [
+ '--- "Hello, World"',
+ '...',
+ ],
+ out => "Hello, World",
+ },
+ { name => 'Hello World 4',
+ in => [
+ '--- "Hello, World"',
+ '...',
+ ],
+ out => "Hello, World",
+ },
+ { name => 'Hello World 4',
+ in => [
+ '--- >',
+ ' Hello,',
+ ' World',
+ '...',
+ ],
+ out => "Hello, World\n",
+ },
+ { name => 'Hello World 5',
+ in => [
+ '--- >',
+ ' Hello,',
+ ' World',
+ '...',
+ ],
+ error => qr{Missing\s+'[.][.][.]'},
+ },
+ { name => 'Simple array',
+ in => [
+ '---',
+ '- 1',
+ '- 2',
+ '- 3',
+ '...',
+ ],
+ out => [ '1', '2', '3' ],
+ },
+ { name => 'Mixed array',
+ in => [
+ '---',
+ '- 1',
+ '- \'two\'',
+ '- "three\n"',
+ '...',
+ ],
+ out => [ '1', 'two', "three\n" ],
+ },
+ { name => 'Hash in array',
+ in => [
+ '---',
+ '- 1',
+ '- two: 2',
+ '- 3',
+ '...',
+ ],
+ out => [ '1', { two => '2' }, '3' ],
+ },
+ { name => 'Hash in array 2',
+ in => [
+ '---',
+ '- 1',
+ '- two: 2',
+ ' three: 3',
+ '- 4',
+ '...',
+ ],
+ out => [ '1', { two => '2', three => '3' }, '4' ],
+ },
+ { name => 'Nested array',
+ in => [
+ '---',
+ '- one',
+ '-',
+ ' - two',
+ ' -',
+ ' - three',
+ ' - four',
+ '- five',
+ '...',
+ ],
+ out => [ 'one', [ 'two', ['three'], 'four' ], 'five' ],
+ },
+ { name => 'Nested hash',
+ in => [
+ '---',
+ 'one:',
+ ' five: 5',
+ ' two:',
+ ' four: 4',
+ ' three: 3',
+ 'six: 6',
+ '...',
+ ],
+ out => {
+ one => { two => { three => '3', four => '4' }, five => '5' },
+ six => '6'
+ },
+ },
+
+ { name => 'Original YAML::Tiny test',
+ in => [
+ '---',
+ 'invoice: 34843',
+ 'date : 2001-01-23',
+ 'bill-to:',
+ ' given : Chris',
+ ' family : Dumars',
+ ' address:',
+ ' lines: |',
+ ' 458 Walkman Dr.',
+ ' Suite #292',
+ ' city : Royal Oak',
+ ' state : MI',
+ ' postal : 48046',
+ 'product:',
+ ' - sku : BL394D',
+ ' quantity : 4',
+ ' description : Basketball',
+ ' price : 450.00',
+ ' - sku : BL4438H',
+ ' quantity : 1',
+ ' description : Super Hoop',
+ ' price : 2392.00',
+ 'tax : 251.42',
+ 'total: 4443.52',
+ 'comments: >',
+ ' Late afternoon is best.',
+ ' Backup contact is Nancy',
+ ' Billsmer @ 338-4338',
+ '...',
+ ],
+ out => {
+ 'bill-to' => {
+ 'given' => 'Chris',
+ 'address' => {
+ 'city' => 'Royal Oak',
+ 'postal' => '48046',
+ 'lines' => "458 Walkman Dr.\nSuite #292\n",
+ 'state' => 'MI'
+ },
+ 'family' => 'Dumars'
+ },
+ 'invoice' => '34843',
+ 'date' => '2001-01-23',
+ 'tax' => '251.42',
+ 'product' => [
+ { 'sku' => 'BL394D',
+ 'quantity' => '4',
+ 'price' => '450.00',
+ 'description' => 'Basketball'
+ },
+ { 'sku' => 'BL4438H',
+ 'quantity' => '1',
+ 'price' => '2392.00',
+ 'description' => 'Super Hoop'
+ }
+ ],
+ 'comments' =>
+ "Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338\n",
+ 'total' => '4443.52'
+ }
+ },
+
+ # Tests harvested from YAML::Tiny
+ { in => ['...'],
+ name => 'Regression: empty',
+ error => qr{document\s+header\s+not\s+found}
+ },
+ { in => [
+ '# comment',
+ '...'
+ ],
+ name => 'Regression: only_comment',
+ error => qr{document\s+header\s+not\s+found}
+ },
+ { out => undef,
+ in => [
+ '---',
+ '...'
+ ],
+ name => 'Regression: only_header',
+ error => qr{Premature\s+end}i,
+ },
+ { out => undef,
+ in => [
+ '---',
+ '---',
+ '...'
+ ],
+ name => 'Regression: two_header',
+ error => qr{Unexpected\s+start}i,
+ },
+ { out => undef,
+ in => [
+ '--- ~',
+ '...'
+ ],
+ name => 'Regression: one_undef'
+ },
+ { out => undef,
+ in => [
+ '--- ~',
+ '...'
+ ],
+ name => 'Regression: one_undef2'
+ },
+ { in => [
+ '--- ~',
+ '---',
+ '...'
+ ],
+ name => 'Regression: two_undef',
+ error => qr{Missing\s+'[.][.][.]'},
+ },
+ { out => 'foo',
+ in => [
+ '--- foo',
+ '...'
+ ],
+ name => 'Regression: one_scalar',
+ },
+ { out => 'foo',
+ in => [
+ '--- foo',
+ '...'
+ ],
+ name => 'Regression: one_scalar2',
+ },
+ { in => [
+ '--- foo',
+ '--- bar',
+ '...'
+ ],
+ name => 'Regression: two_scalar',
+ error => qr{Missing\s+'[.][.][.]'},
+ },
+ { out => ['foo'],
+ in => [
+ '---',
+ '- foo',
+ '...'
+ ],
+ name => 'Regression: one_list1'
+ },
+ { out => [
+ 'foo',
+ 'bar'
+ ],
+ in => [
+ '---',
+ '- foo',
+ '- bar',
+ '...'
+ ],
+ name => 'Regression: one_list2'
+ },
+ { out => [
+ undef,
+ 'bar'
+ ],
+ in => [
+ '---',
+ '- ~',
+ '- bar',
+ '...'
+ ],
+ name => 'Regression: one_listundef'
+ },
+ { out => { 'foo' => 'bar' },
+ in => [
+ '---',
+ 'foo: bar',
+ '...'
+ ],
+ name => 'Regression: one_hash1'
+ },
+ { out => {
+ 'foo' => 'bar',
+ 'this' => undef
+ },
+ in => [
+ '---',
+ 'foo: bar',
+ 'this: ~',
+ '...'
+ ],
+ name => 'Regression: one_hash2'
+ },
+ { out => {
+ 'foo' => [
+ 'bar',
+ undef,
+ 'baz'
+ ]
+ },
+ in => [
+ '---',
+ 'foo:',
+ ' - bar',
+ ' - ~',
+ ' - baz',
+ '...'
+ ],
+ name => 'Regression: array_in_hash'
+ },
+ { out => {
+ 'bar' => { 'foo' => 'bar' },
+ 'foo' => undef
+ },
+ in => [
+ '---',
+ 'foo: ~',
+ 'bar:',
+ ' foo: bar',
+ '...'
+ ],
+ name => 'Regression: hash_in_hash'
+ },
+ { out => [
+ { 'foo' => undef,
+ 'this' => 'that'
+ },
+ 'foo', undef,
+ { 'foo' => 'bar',
+ 'this' => 'that'
+ }
+ ],
+ in => [
+ '---',
+ '-',
+ ' foo: ~',
+ ' this: that',
+ '- foo',
+ '- ~',
+ '-',
+ ' foo: bar',
+ ' this: that',
+ '...'
+ ],
+ name => 'Regression: hash_in_array'
+ },
+ { out => ['foo'],
+ in => [
+ '---',
+ '- \'foo\'',
+ '...'
+ ],
+ name => 'Regression: single_quote1'
+ },
+ { out => [' '],
+ in => [
+ '---',
+ '- \' \'',
+ '...'
+ ],
+ name => 'Regression: single_spaces'
+ },
+ { out => [''],
+ in => [
+ '---',
+ '- \'\'',
+ '...'
+ ],
+ name => 'Regression: single_null'
+ },
+ { out => ' ',
+ in => [
+ '--- " "',
+ '...'
+ ],
+ name => 'Regression: only_spaces'
+ },
+ { out => [
+ undef,
+ { 'foo' => 'bar',
+ 'this' => 'that'
+ },
+ 'baz'
+ ],
+ in => [
+ '---',
+ '- ~',
+ '- foo: bar',
+ ' this: that',
+ '- baz',
+ '...'
+ ],
+ name => 'Regression: inline_nested_hash'
+ },
+ { name => "Unprintables",
+ in => [
+ "---",
+ "- \"\\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\"",
+ "- \" !\\\"#\$%&'()*+,-./\"",
+ "- 0123456789:;<=>?",
+ "- '\@ABCDEFGHIJKLMNO'",
+ "- 'PQRSTUVWXYZ[\\]^_'",
+ "- '`abcdefghijklmno'",
+ "- 'pqrstuvwxyz{|}~\177'",
+ "- \200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217",
+ "- \220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237",
+ "- \240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257",
+ "- \260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277",
+ "- \300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317",
+ "- \320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337",
+ "- \340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357",
+ "- \360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377",
+ "..."
+ ],
+ out => [
+ "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17",
+ "\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37",
+ " !\"#\$%&'()*+,-./",
+ "0123456789:;<=>?",
+ "\@ABCDEFGHIJKLMNO",
+ "PQRSTUVWXYZ[\\]^_",
+ "`abcdefghijklmno",
+ "pqrstuvwxyz{|}~\177",
+ "\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217",
+ "\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237",
+ "\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257",
+ "\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277",
+ "\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317",
+ "\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337",
+ "\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357",
+ "\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377"
+ ],
+ },
+ { name => 'Quoted hash keys',
+ in => [
+ '---',
+ ' "quoted": Magic!',
+ ' "\n\t": newline, tab',
+ '...',
+ ],
+ out => {
+ quoted => 'Magic!',
+ "\n\t" => 'newline, tab',
+ },
+ },
+ );
+
+ plan tests => @SCHEDULE * 5;
+}
+
+sub iter {
+ my $ar = shift;
+ return sub {
+ return shift @$ar;
+ };
+}
+
+for my $test (@SCHEDULE) {
+ my $name = $test->{name};
+ ok my $yaml = TAP::Parser::YAMLish::Reader->new, "$name: Created";
+ isa_ok $yaml, 'TAP::Parser::YAMLish::Reader';
+
+ my $source = join( "\n", @{ $test->{in} } ) . "\n";
+
+ my $iter = iter( $test->{in} );
+ my $got = eval { $yaml->read($iter) };
+
+ my $raw = $yaml->get_raw;
+
+ if ( my $err = $test->{error} ) {
+ unless ( like $@, $err, "$name: Error message" ) {
+ diag "Error: $@\n";
+ }
+ ok !$got, "$name: No result";
+ pass;
+ }
+ else {
+ my $want = $test->{out};
+ unless ( ok !$@, "$name: No error" ) {
+ diag "Error: $@\n";
+ }
+ is_deeply $got, $want, "$name: Result matches";
+ is $raw, $source, "$name: Captured source matches";
+ }
+}
--- /dev/null
+package App::Prove::Plugin::Dummy;
+
+sub import {
+ main::test_log_import( @_ );
+}
+
+1;
# Has to work on 5.004 which doesn't have Tie::StdHandle.
package Dev::Null;
-sub WRITE {}
-sub PRINT {}
-sub PRINTF {}
+sub WRITE { }
+sub PRINT { }
+sub PRINTF { }
+
sub TIEHANDLE {
my $class = shift;
- my $fh = do { local *HANDLE; \*HANDLE };
+ my $fh = do { local *HANDLE; \*HANDLE };
return bless $fh, $class;
}
-sub READ {}
-sub READLINE {}
-sub GETC {}
+sub READ { }
+sub READLINE { }
+sub GETC { }
1;
--- /dev/null
+package IO::c55Capture;
+
+use IO::Handle;
+
+=head1 Name
+
+t/lib/IO::c55Capture - a wafer-thin test support package
+
+=head1 Why!?
+
+Compatibility with 5.5.3 and no external dependencies.
+
+=head1 Usage
+
+Works with a global filehandle:
+
+ # set a spool to write to
+ tie local *STDOUT, 'IO::c55Capture';
+ ...
+ # clear and retrieve buffer list
+ my @spooled = tied(*STDOUT)->dump();
+
+Or, a lexical (and autocreated) filehandle:
+
+ my $capture = IO::c55Capture->new_handle;
+ ...
+ my @output = tied($$capture)->dump;
+
+Note the '$$' dereference.
+
+=cut
+
+# XXX actually returns an IO::Handle :-/
+sub new_handle {
+ my $class = shift;
+ my $handle = IO::Handle->new;
+ tie $$handle, $class;
+ return ($handle);
+}
+
+sub TIEHANDLE {
+ return bless [], __PACKAGE__;
+}
+
+sub PRINT {
+ my $self = shift;
+
+ push @$self, @_;
+}
+
+sub PRINTF {
+ my $self = shift;
+ push @$self, sprintf(@_);
+}
+
+sub dump {
+ my $self = shift;
+ my @got = @$self;
+ @$self = ();
+ return @got;
+}
+
+package util;
+
+use IO::File;
+
+# mostly stolen from Module::Build MBTest.pm
+
+{ # backwards compatible temp filename recipe adapted from perlfaq
+ my $tmp_count = 0;
+ my $tmp_base_name = sprintf( "%d-%d", $$, time() );
+
+ sub temp_file_name {
+ sprintf( "%s-%04d", $tmp_base_name, ++$tmp_count );
+ }
+}
+########################################################################
+
+sub save_handle {
+ my ( $handle, $subr ) = @_;
+ my $outfile = temp_file_name();
+
+ local *SAVEOUT;
+ open SAVEOUT, ">&" . fileno($handle)
+ or die "Can't save output handle: $!";
+ open $handle, "> $outfile" or die "Can't create $outfile: $!";
+
+ eval { $subr->() };
+ my $err = $@;
+ open $handle, ">&SAVEOUT" or die "Can't restore output: $!";
+
+ my $ret = slurp($outfile);
+ 1 while unlink $outfile;
+ $err and die $err;
+ return $ret;
+}
+
+sub stdout_of { save_handle( \*STDOUT, @_ ) }
+sub stderr_of { save_handle( \*STDERR, @_ ) }
+
+sub stdout_stderr_of {
+ my $subr = shift;
+ my ( $stdout, $stderr );
+ $stdout = stdout_of(
+ sub {
+ $stderr = stderr_of($subr);
+ }
+ );
+ return ( $stdout, $stderr );
+}
+
+sub slurp {
+ my $fh = IO::File->new( $_[0] ) or die "Can't open $_[0]: $!";
+ local $/;
+ return scalar <$fh>;
+}
+
+1;
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+package NoFork;
+
+BEGIN {
+ *CORE::GLOBAL::fork = sub { die "you should not fork" };
+}
+use Config;
+tied(%Config)->{d_fork} = 0; # blatant lie
+
+=begin TEST
+
+Assuming not to much chdir:
+
+ PERL5OPT='-It/lib -MNoFork' perl -Ilib bin/prove -r t
+
+=end TEST
+
+=cut
+
+1;
+
+# vim:ts=4:sw=4:et:sta
--- /dev/null
+1..1
+ok 1
--- /dev/null
+--should be --split correctly # No comment!
+Can "quote things" 'using single or' "double quotes"
+
+# More stuff
+--this
+is
+'OK?'
--- /dev/null
+---
+invoice: 34843
+date : 2001-01-23
+bill-to:
+ given : Chris
+ family : Dumars
+ address:
+ lines: |
+ 458 Walkman Dr.
+ Suite #292
+ city : Royal Oak
+ state : MI
+ postal : 48046
+product:
+ - sku : BL394D
+ quantity : 4
+ description : Basketball
+ price : 450.00
+ - sku : BL4438H
+ quantity : 1
+ description : Super Hoop
+ price : 2392.00
+tax : 251.42
+total: 4443.52
+comments: >
+ Late afternoon is best.
+ Backup contact is Nancy
+ Billsmer @ 338-4338
+
+# Sleep makes Mac OS open3 race problem more repeatable
+sleep 1;
print <<DUMMY_TEST;
1..5
ok 1
print <<DUMMY_TEST;
-1..10 todo 4 10
+1..10
ok 1
ok 2 basset hounds got long ears
-not ok 3 all hell broke lose
-ok 4
-ok
-ok 6
-ok 7 # Skip contract negociations
-ok 8
-not ok 9
+not ok 3 all hell broke loose
+not ok 4 # TODO if I heard a voice from heaven ...
+ok say "live without loving",
+ok 6 I'd beg off.
+ok 7 # Skip contract negotiations
+ok 8 Girls are such exquisite hell
+ok 9 Elegy 9B # TOdO
not ok 10
DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..10 todo 4 10
+ok 1
+ok 2 basset hounds got long ears
+not ok 3 all hell broke lose
+ok 4
+ok
+ok 6
+ok 7 # Skip contract negociations
+ok 8
+not ok 9
+not ok 10
+DUMMY_TEST
--- /dev/null
+# Used to test Process.pm
+
+use Time::HiRes qw(sleep);
+
+my $delay = 0.01;
+
+$| = 1;
+
+my @parts = (
+ "1.",
+ ".5\n",
+ "ok 1 00000\n",
+ "ok 2\nnot",
+ " ok 3",
+ "\nok 4\nok ",
+ "5 00000",
+ ""
+);
+
+my $delay_at = shift || 0;
+
+while ( @parts ) {
+ sleep $delay if ( $delay_at & 1 );
+ $delay_at >>= 1;
+ print shift @parts;
+}
+sleep $delay if ( $delay_at & 1 );
--- /dev/null
+print <<DUMMY_TEST;
+ok 1 Interlock activated
+ok 2 Megathrusters are go
+ok 3 Head formed
+ok 4 Blazing sword formed
+ok 5 Robeast destroyed
+1..5
+DUMMY_TEST
-use if ($^O eq 'VMS'), vmsish => 'hushed';
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
exit 1; # exit because die() can be noisy
ok 4
DUMMY_TEST
-use if $^O eq 'VMS', vmsish => 'hushed';
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
exit 1;
1..4
DUMMY_TEST
-use if $^O eq 'VMS', vmsish => 'hushed';
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
exit 1;
--- /dev/null
+print <<DUMMY_TEST;
+1..4
+ok 1
+ok 2
+ok 3
+DUMMY_TEST
+
+eval "use vmsish 'hushed'" if ($^O eq 'VMS');
+exit 1;
--- /dev/null
+print '1..', scalar(@ARGV), "\n";
+print "ok $_ ", $ARGV[ $_ - 1 ], "\n" for 1 .. @ARGV;
--- /dev/null
+print <<DUMMY_TEST;
+1..2
+ok 1 Should parse as literal backslash --> \\
+ok 2 Not a continuation line
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..3
+ok 1 Not a \\# TODO
+ok 2 Not a \\# SKIP
+ok 3 Escaped \\\\\\#
+DUMMY_TEST
use lib qw(t/lib);
use Test::More tests => 1;
-ok( grep(/we_added_this_lib/, @INC) );
+ok( grep( /examples/, @INC ) );
--- /dev/null
+print <<DUMMY_TEST;
+this is junk
+# this is a comment
+1..1
+ok 1
+DUMMY_TEST
--- /dev/null
+use strict;
+
+sub _autoflush {
+ my $flushed = shift;
+ my $old_fh = select $flushed;
+ $| = 1;
+ select $old_fh;
+}
+
+_autoflush( \*STDOUT );
+_autoflush( \*STDERR );
+
+print STDOUT "one\n";
+print STDERR "two\n\n";
+print STDOUT "three\n";
--- /dev/null
+use Test::More;
+plan tests => 1;
+ok 23, 42;
--- /dev/null
+print <<DUMMY_TEST;
+1..3
+ok 1
+not ok 2
+# Failed test at ../../andy/schwern.pl line 17.
+# got: '23'
+# expected: '42'
+not ok 3 # TODO Roman numerials still not a built in type
+# Failed (TODO) test at ../../andy/schwern.pl line 20.
+# got: 'XXIII'
+# expected: '23'
+# Looks like you failed 1 test of 3.
+DUMMY_TEST
--- /dev/null
+#
+# This was causing parse failures due to an error in the TAP specification.
+# Hash marks *are* allowed in the description.
+#
+print <<DUMMY;
+1..5
+ok 1
+ok 2
+ok 3 # skipped on foobar system
+# 1234567890123456789012345678901234567890
+ok 4
+# 1234567890123456789012345678901234567890
+ok 5
+DUMMY
print "ok 1\n";
my $warning = '';
$SIG{__WARN__} = sub { $warning .= $_[0] };
-eval("#" . substr($0, 0, 0));
+eval( "#" . substr( $0, 0, 0 ) );
print $warning ? "not ok 2\n" : "ok 2\n";
--- /dev/null
+print <<DUMMY_TEST;
+TAP version 13
+1..5
+ok 1
+ok 2
+ ---
+ -
+ fnurk: skib
+ ponk: gleeb
+ -
+ bar: krup
+ foo: plink
+ ...
+ok 3
+ok 4
+ ---
+ expected:
+ - 1
+ - 2
+ - 4
+ got:
+ - 1
+ - pong
+ - 4
+ ...
+ok 5
+DUMMY_TEST
print <<DUMMY_TEST;
-1..0 # skip: rope
+1..0 # skipping: rope
DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+TAP version 13
+1..0 # skipping: rope
+DUMMY_TEST
--- /dev/null
+# gforth TAP generates a space after the plan. Should probably be allowed.
+print "1..5 \n";
+print "ok $_ \n" for 1..5;
--- /dev/null
+use Test::More 'no_plan';
+diag 'comments';
+ok 1;
+ok 1;
+ok 1;
+diag 'comment';
+ok 1;
+diag 'more ignored stuff';
+diag 'and yet more';
use Test::More tests => 1;
eval { kill 0, $^X };
-like( $@, '/^Insecure dependency/', '-T honored' );
+like( $@, '/^Insecure dependency/', '-T honored' );
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
kill 0, $^X;
}
-like( $warnings, '/^Insecure dependency/', '-t honored' );
+like( $warnings, '/^Insecure dependency/', '-t honored' );
print <<DUMMY_TEST;
-1..5 todo 3 2;
+1..5 todo 3 2;
ok 1
ok 2
not ok 3
--- /dev/null
+print <<'END';
+1..1
+not ok 1 Hamlette # TODOORNOTTODO
+END
+
--- /dev/null
+print <<DUMMY_TEST;
+TAP version 13
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+1..5
+TAP version 13
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+print <<DUMMY_TEST;
+TAP version 12
+1..5
+ok 1
+ok 2
+ok 3
+ok 4
+ok 5
+DUMMY_TEST
--- /dev/null
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..1
+ok 1 - this is a test
+END_TESTS
--- /dev/null
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..2
+ok 1 - this is a test
+not ok 2 - this is another test
+1..2
+END_TESTS
--- /dev/null
+#!/usr/bin/perl
+
+print "1..1\n";
+
+die "I should have no args -- @ARGV" if (@ARGV);
+print "ok 1 - this is a test\n";
+
--- /dev/null
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..3
+ok 1 - this is a test
+not ok 2 - we have a something # TODO some output
+ok 3 houston, we don't have liftoff # SKIP no funding
+END_TESTS
--- /dev/null
+#!/usr/bin/perl
+
+print <<'END_TESTS';
+1..2
+ok 1 - this is a test
+not ok 2 - this is another test
+END_TESTS
--- /dev/null
+#!/usr/bin/perl -wT
+
+use lib 't/lib';
+use Test::More tests => 1;
+
+ok 1;
projects / p5sagit/p5-mst-13.2.git / commitdiff