[perl.git] branch blead, updated. GitLive-blead-740-gbdaf8c6

Steve Hay

2009-03-06 15:24:48 UTC

In perl.git, the branch blead has been updated

<http://perl5.git.perl.org/perl.git/commitdiff/bdaf8c65d37b1e4fb9dee9eed906961f41184db9?hp=69e34dac306d4c474199dd63fa07c93e2e08570a>

- Log -----------------------------------------------------------------
commit bdaf8c65d37b1e4fb9dee9eed906961f41184db9
Author: Steve Hay <***@planit.com>
Date: Fri Mar 6 15:22:23 2009 +0000

Upgrade to Test-Harness-3.16

But keep Test/Harness -> Test-Harness changes from commit f715bbfb20b232d289d3eddf42aec434ddd9dd4c
and do likewise in new files file.t and harness-bailout.t too.
-----------------------------------------------------------------------

Summary of changes:
MANIFEST | 8 +
ext/Test-Harness/Changes | 21 +-
ext/Test-Harness/bin/prove | 26 ++
ext/Test-Harness/lib/App/Prove.pm | 141 ++++++--
ext/Test-Harness/lib/App/Prove/State.pm | 85 +++--
ext/Test-Harness/lib/App/Prove/State/Result.pm | 15 +-
.../lib/App/Prove/State/Result/Test.pm | 13 +-
ext/Test-Harness/lib/TAP/Base.pm | 16 +-
.../lib/TAP/Formatter/{Console.pm => Base.pm} | 68 +---
ext/Test-Harness/lib/TAP/Formatter/Color.pm | 4 +-
ext/Test-Harness/lib/TAP/Formatter/Console.pm | 404 +-------------------
.../lib/TAP/Formatter/Console/ParallelSession.pm | 49 ++--
.../lib/TAP/Formatter/Console/Session.pm | 166 +--------
ext/Test-Harness/lib/TAP/Formatter/File.pm | 58 +++
ext/Test-Harness/lib/TAP/Formatter/File/Session.pm | 109 ++++++
ext/Test-Harness/lib/TAP/Formatter/Session.pm | 175 +++++++++
ext/Test-Harness/lib/TAP/Harness.pm | 51 ++--
ext/Test-Harness/lib/TAP/Object.pm | 25 ++-
ext/Test-Harness/lib/TAP/Parser.pm | 60 ++--
ext/Test-Harness/lib/TAP/Parser/Aggregator.pm | 14 +-
ext/Test-Harness/lib/TAP/Parser/Grammar.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Iterator.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Iterator/Array.pm | 4 +-
.../lib/TAP/Parser/Iterator/Process.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/IteratorFactory.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Multiplexer.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result.pm | 12 +-
ext/Test-Harness/lib/TAP/Parser/Result/Bailout.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/Comment.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/Plan.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/Pragma.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/Test.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/Unknown.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/Version.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Result/YAML.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/ResultFactory.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Scheduler.pm | 18 +-
ext/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm | 4 +-
.../lib/TAP/Parser/Scheduler/Spinner.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Source.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm | 49 ++--
ext/Test-Harness/lib/TAP/Parser/Utils.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm | 4 +-
ext/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm | 4 +-
ext/Test-Harness/lib/Test/Harness.pm | 54 +--
ext/Test-Harness/t/aggregator.t | 6 +-
ext/Test-Harness/t/compat/failure.t | 7 +-
ext/Test-Harness/t/compat/inc-propagation.t | 7 +-
ext/Test-Harness/t/file.t | 402 +++++++++++++++++++
ext/Test-Harness/t/harness-bailout.t | 58 +++
ext/Test-Harness/t/harness.t | 48 ++-
ext/Test-Harness/t/iterators.t | 2 +-
ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm | 2 +
ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm | 13 +
ext/Test-Harness/t/parse.t | 5 +-
ext/Test-Harness/t/perl5lib.t | 48 +++
ext/Test-Harness/t/prove.t | 51 +++-
ext/Test-Harness/t/proverun.t | 2 +-
ext/Test-Harness/t/regression.t | 185 +++++-----
ext/Test-Harness/t/taint.t | 42 +--
61 files changed, 1558 insertions(+), 1049 deletions(-)
copy ext/Test-Harness/lib/TAP/Formatter/{Console.pm => Base.pm} (88%)
create mode 100644 ext/Test-Harness/lib/TAP/Formatter/File.pm
create mode 100644 ext/Test-Harness/lib/TAP/Formatter/File/Session.pm
create mode 100644 ext/Test-Harness/lib/TAP/Formatter/Session.pm
create mode 100644 ext/Test-Harness/t/file.t
create mode 100644 ext/Test-Harness/t/harness-bailout.t
create mode 100644 ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm
create mode 100644 ext/Test-Harness/t/perl5lib.t

diff --git a/MANIFEST b/MANIFEST
index 1ba1298..e02106e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1186,10 +1186,14 @@ ext/Test-Harness/lib/App/Prove/State.pm Gubbins for the prove utility
ext/Test-Harness/lib/App/Prove/State/Result.pm Gubbins for the prove utility
ext/Test-Harness/lib/App/Prove/State/Result/Test.pm Gubbins for the prove utility
ext/Test-Harness/lib/TAP/Base.pm A parser for Test Anything Protocol
+ext/Test-Harness/lib/TAP/Formatter/Base.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Formatter/Color.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Formatter/Console.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Formatter/Console/Session.pm A parser for Test Anything Protocol
+ext/Test-Harness/lib/TAP/Formatter/File.pm A parser for Test Anything Protocol
+ext/Test-Harness/lib/TAP/Formatter/File/Session.pm A parser for Test Anything Protocol
+ext/Test-Harness/lib/TAP/Formatter/Session.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Harness.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Object.pm A parser for Test Anything Protocol
ext/Test-Harness/lib/TAP/Parser/Aggregator.pm A parser for Test Anything Protocol
@@ -1239,12 +1243,15 @@ ext/Test-Harness/t/data/catme.1 Test data for Test::Harness
ext/Test-Harness/t/data/proverc Test data for Test::Harness
ext/Test-Harness/t/data/sample.yml Test data for Test::Harness
ext/Test-Harness/t/errors.t Test::Harness test
+ext/Test-Harness/t/file.t Test::Harness test
ext/Test-Harness/t/glob-to-regexp.t Test::Harness test
ext/Test-Harness/t/grammar.t Test::Harness test
+ext/Test-Harness/t/harness-bailout.t Test::Harness test
ext/Test-Harness/t/harness-subclass.t Test::Harness test
ext/Test-Harness/t/harness.t Test::Harness test
ext/Test-Harness/t/iterators.t Test::Harness test
ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy.pm Module for testing Test::Harness
+ext/Test-Harness/t/lib/App/Prove/Plugin/Dummy2.pm Module for testing Test::Harness
ext/Test-Harness/t/lib/Dev/Null.pm Module for testing Test::Harness
ext/Test-Harness/t/lib/EmptyParser.pm Module for testing Test::Harness
ext/Test-Harness/t/lib/IO/c55Capture.pm Module for testing Test::Harness
@@ -1266,6 +1273,7 @@ ext/Test-Harness/t/object.t Test::Harness test
ext/Test-Harness/t/parser-config.t Test::Harness test
ext/Test-Harness/t/parser-subclass.t Test::Harness test
ext/Test-Harness/t/parse.t Test::Harness test
+ext/Test-Harness/t/perl5lib.t Test::Harness test
ext/Test-Harness/t/premature-bailout.t Test::Harness test
ext/Test-Harness/t/process.t Test::Harness test
ext/Test-Harness/t/proveenv.t Test::Harness test
diff --git a/ext/Test-Harness/Changes b/ext/Test-Harness/Changes
index 4ae9f1d..44c04bd 100644
--- a/ext/Test-Harness/Changes
+++ b/ext/Test-Harness/Changes
@@ -1,7 +1,26 @@
Revision history for Test-Harness

-
-3.14
+3.16 2009-02-19
+ - Fix path splicing on platforms where the path separator
+ is not ':'.
+ - Fixes/skips for failing Win32 tests.
+ - Don't break with older CPAN::Reporter versions.
+
+3.15 2009-02-17
+ - Refactor getter/setter generation into TAP::Object.
+ - The App::Prove::State::Result::Test now stores the parser object.
+ - After discussion with Andy, agreed to clean up the test output
+ somewhat. t/foo.....ok becomes t/foo.t ... ok
+ - Make Bail out! die instead of exiting. Dies with the same
+ message as 2.64 for (belated) backwards compatibility.
+ - Alex Vaniver's patch to refactor TAP::Formatter::Console into
+ a new class, TAP::Formatter::File and a common base class:
+ TAP::Formatter::Base.
+ - Fix a bug where PERL5LIB might be put in the wrong spot in @INC.
+ #40257
+ - Steve Purkis implemented a plugin mechanism for App::Prove.
+
+3.14 2008-09-13
- Created a proper (ha!) API for prove state results and tests.
- Added --count and --nocount options to prove to control X/Y display
while running tests.
diff --git a/ext/Test-Harness/bin/prove b/ext/Test-Harness/bin/prove
index 01df160..cde1b9b 100644
--- a/ext/Test-Harness/bin/prove
+++ b/ext/Test-Harness/bin/prove
@@ -259,6 +259,32 @@ names of any directories found in C<PERL5LIB> as -I switches. The net
effect of this is that C<PERL5LIB> is honoured even when prove is run in
taint mode.

+=head1 PLUGINS
+
+Plugins can be loaded using the C<< -PI<plugin> >> syntax, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass arguments to your plugin by appending C<=arg1,arg2,etc> to the
+plugin name:
+
+ prove -PMyPlugin=fou,du,fafa
+
+Please check individual plugin documentation for more details.
+
+=head2 Available Plugins
+
+For an up-to-date list of plugins available, please check CPAN:
+
+L<http://search.cpan.org/search?query=App%3A%3AProve+Plugin>
+
+=head2 Writing Plugins
+
+Please see L<App::Prove/PLUGINS>.
+
=cut

# vim:ts=4:sw=4:et:sta
diff --git a/ext/Test-Harness/lib/App/Prove.pm b/ext/Test-Harness/lib/App/Prove.pm
index 29d2f8f..bc665fa 100644
--- a/ext/Test-Harness/lib/App/Prove.pm
+++ b/ext/Test-Harness/lib/App/Prove.pm
@@ -11,19 +11,17 @@ use Getopt::Long;
use App::Prove::State;
use Carp;

-@ISA = qw(TAP::Object);
-
=head1 NAME

App::Prove - Implements the C<prove> command.

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

@@ -53,21 +51,16 @@ use constant PLUGINS => 'App::Prove::Plugin';
my @ATTR;

BEGIN {
+ @ISA = qw(TAP::Object);
+
@ATTR = qw(
archive argv blib show_count color directives exec failures fork
formatter harness includes modules plugins jobs lib merge parse quiet
really_quiet recurse backwards shuffle taint_fail taint_warn timer
verbose warnings_fail warnings_warn show_help show_man show_version
- test_args state dry extension ignore_exit rules state_manager
+ state_class test_args state dry extension ignore_exit rules state_manager
);
- for my $attr (@ATTR) {
- no strict 'refs';
- *$attr = sub {
- my $self = shift;
- $self->{$attr} = shift if @_;
- return $self->{$attr};
- };
- }
+ __PACKAGE__->mk_methods(@ATTR);
}

=head1 METHODS
@@ -108,27 +101,22 @@ sub _initialize {
while ( my ( $env, $attr ) = each %env_provides_default ) {
$self->{$attr} = 1 if $ENV{$env};
}
- $self->state_manager(
- $self->state_class->new( { store => STATE_FILE } ) );
-
+ $self->state_class('App::Prove::State');
return $self;
}

=head3 C<state_class>

-Returns the name of the class used for maintaining state. This class should
-either subclass from C<App::Prove::State> or provide an identical interface.
+Getter/setter for the name of the class used for maintaining state. This
+class should either subclass from C<App::Prove::State> or provide an identical
+interface.

=head3 C<state_manager>

-Getter/setter for the an instane of the C<state_class>.
+Getter/setter for the instance of the C<state_class>.

=cut

-sub state_class {
- return 'App::Prove::State';
-}
-
=head3 C<add_rc_file>

$prove->add_rc_file('myproj/.proverc');
@@ -400,19 +388,22 @@ sub _find_module {
}

sub _load_extension {
- my ( $self, $class, @search ) = @_;
+ my ( $self, $name, @search ) = @_;

my @args = ();
- if ( $class =~ /^(.*?)=(.*)/ ) {
- $class = $1;
+ if ( $name =~ /^(.*?)=(.*)/ ) {
+ $name = $1;
@args = split( /,/, $2 );
}

- if ( my $name = $self->_find_module( $class, @search ) ) {
- $name->import(@args);
+ if ( my $class = $self->_find_module( $name, @search ) ) {
+ $class->import(@args);
+ if ( $class->can('load') ) {
+ $class->load( { app_prove => $self, args => [@args] } );
+ }
}
else {
- croak "Can't load module $class";
+ croak "Can't load module $name";
}
}

@@ -437,6 +428,11 @@ command line tool consists of the following code:
sub run {
my $self = shift;

+ unless ( $self->state_manager ) {
+ $self->state_manager(
+ $self->state_class->new( { store => STATE_FILE } ) );
+ }
+
if ( $self->show_help ) {
$self->_help(1);
}
@@ -675,6 +671,8 @@ calling C<run>.

=item C<state>

+=item C<state_class>
+
=item C<taint_fail>

=item C<taint_warn>
@@ -690,3 +688,88 @@ calling C<run>.
=item C<warnings_warn>

=back
+
+=head1 PLUGINS
+
+C<App::Prove> provides support for 3rd-party plugins. These are currently
+loaded at run-time, I<after> arguments have been parsed (so you can not
+change the way arguments are processed, sorry), typically with the
+C<< -PI<plugin> >> switch, eg:
+
+ prove -PMyPlugin
+
+This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing
+that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit.
+
+You can pass an argument to your plugin by appending an C<=> after the plugin
+name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas:
+
+ prove -PMyPlugin=foo,bar,baz
+
+These are passed in to your plugin's C<load()> class method (if it has one),
+along with a reference to the C<App::Prove> object that is invoking your plugin:
+
+ sub load {
+ my ($class, $p) = @_;
+
+ my @args = @{ $p->{args} };
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ $p->{app_prove}->do_something;
+ ...
+ }
+
+Note that the user's arguments are also passed to your plugin's C<import()>
+function as a list, eg:
+
+ sub import {
+ my ($class, @args) = @_;
+ # @args will contain ( 'foo', 'bar', 'baz' )
+ ...
+ }
+
+This is for backwards compatibility, and may be deprecated in the future.
+
+=head2 Sample Plugin
+
+Here's a sample plugin, for your reference:
+
+ package App::Prove::Plugin::Foo;
+
+ # Sample plugin, try running with:
+ # prove -PFoo=bar -r -j3
+ # prove -PFoo -Q
+ # prove -PFoo=bar,My::Formatter
+
+ use strict;
+ use warnings;
+
+ sub load {
+ my ($class, $p) = @_;
+ my @args = @{ $p->{args} };
+ my $app = $p->{app_prove};
+
+ print "loading plugin: $class, args: ", join(', ', @args ), "\n";
+
+ # turn on verbosity
+ $app->verbose( 1 );
+
+ # set the formatter?
+ $app->formatter( $args[1] ) if @args > 1;
+
+ # print some of App::Prove's state:
+ for my $attr (qw( jobs quiet really_quiet recurse verbose )) {
+ my $val = $app->$attr;
+ $val = 'undef' unless defined( $val );
+ print "$attr: $val\n";
+ }
+
+ return 1;
+ }
+
+ 1;
+
+=head1 SEE ALSO
+
+L<prove>, L<TAP::Harness>
+
+=cut
diff --git a/ext/Test-Harness/lib/App/Prove/State.pm b/ext/Test-Harness/lib/App/Prove/State.pm
index 2b284d2..6eef184 100644
--- a/ext/Test-Harness/lib/App/Prove/State.pm
+++ b/ext/Test-Harness/lib/App/Prove/State.pm
@@ -12,7 +12,10 @@ use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
use TAP::Base;

-@ISA = qw( TAP::Base );
+BEGIN {
+ @ISA = qw( TAP::Base );
+ __PACKAGE__->mk_methods('result_class');
+}

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant NEED_GLOB => IS_WIN32;
@@ -23,11 +26,11 @@ App::Prove::State - State storage for the C<prove> command.

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

@@ -48,6 +51,24 @@ and the operations that may be performed on it.

=head3 C<new>

+Accepts a hashref with the following key/value pairs:
+
+=over 4
+
+=item * C<store>
+
+The filename of the data store holding the data that App::Prove::State reads.
+
+=item * C<extension> (optional)
+
+The test name extension. Defaults to C<.t>.
+
+=item * C<result_class> (optional)
+
+The name of the C<result_class>. Defaults to C<App::Prove::State::Result>.
+
+=back
+
=cut

# override TAP::Base::new:
@@ -56,17 +77,19 @@ sub new {
my %args = %{ shift || {} };

my $self = bless {
- _ => $class->result_class->new(
- { tests => {},
- generation => 1,
- }
- ),
select => [],
seq => 1,
store => delete $args{store},
- extension => delete $args{extension} || '.t',
+ extension => ( delete $args{extension} || '.t' ),
+ result_class =>
+ ( delete $args{result_class} || 'App::Prove::State::Result' ),
}, $class;

+ $self->{_} = $self->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ );
my $store = $self->{store};
$self->load($store)
if defined $store && -f $store;
@@ -76,16 +99,12 @@ sub new {

=head2 C<result_class>

-Returns the name of the class used for tracking test results. This class
-should either subclass from C<App::Prove::State::Result> or provide an
+Getter/setter for the name of the class used for tracking test results. This
+class should either subclass from C<App::Prove::State::Result> or provide an
identical interface.

=cut

-sub result_class {
- return 'App::Prove::State::Result';
-}
-
=head2 C<extension>

Get or set the extension files must have in order to be considered
@@ -107,7 +126,7 @@ Get the results of the last test run. Returns a C<result_class()> instance.

sub results {
my $self = shift;
- $self->{_} || $self->result_class->new
+ $self->{_} || $self->result_class->new;
}

=head2 C<commit>
@@ -118,8 +137,8 @@ Save the test results. Should be called after all tests have run.

sub commit {
my $self = shift;
- if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
- $self->save($store);
+ if ( $self->{should_save} ) {
+ $self->save;
}
}

@@ -373,15 +392,6 @@ Store the results of a test.

=cut

-sub observe_test {
- my ( $self, $test, $parser ) = @_;
- $self->_record_test(
- $test->[0],
- scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
- scalar( $parser->todo ), $parser->start_time, $parser->end_time,
- );
-}
-
# Store:
# last fail time
# last pass time
@@ -391,10 +401,18 @@ sub observe_test {
# total failures
# total passes
# state generation
+# parser
+
+sub observe_test {

-sub _record_test {
- my ( $self, $name, $fail, $todo, $start_time, $end_time ) = @_;
- my $test = $self->results->test($name);
+ my ( $self, $test_info, $parser ) = @_;
+ my $name = $test_info->[0];
+ my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
+ my $todo = scalar( $parser->todo );
+ my $start_time = $parser->start_time;
+ my $end_time = $parser->end_time,
+
+ my $test = $self->results->test($name);

$test->sequence( $self->{seq}++ );
$test->generation( $self->results->generation );
@@ -404,6 +422,8 @@ sub _record_test {
$test->num_todo($todo);
$test->elapsed( $end_time - $start_time );

+ $test->parser($parser);
+
if ($fail) {
$test->total_failures( $test->total_failures + 1 );
$test->last_fail_time($end_time);
@@ -421,13 +441,14 @@ Write the state to a file.
=cut

sub save {
- my ( $self, $name ) = @_;
+ my ($self) = @_;

+ my $store = $self->{store} or return;
$self->results->last_run_time( $self->get_time );

my $writer = TAP::Parser::YAMLish::Writer->new;
local *FH;
- open FH, ">$name" or croak "Can't write $name ($!)";
+ open FH, ">$store" or croak "Can't write $store ($!)";
$writer->write( $self->results->raw, \*FH );
close FH;
}
diff --git a/ext/Test-Harness/lib/App/Prove/State/Result.pm b/ext/Test-Harness/lib/App/Prove/State/Result.pm
index 37337ea..a087da4 100644
--- a/ext/Test-Harness/lib/App/Prove/State/Result.pm
+++ b/ext/Test-Harness/lib/App/Prove/State/Result.pm
@@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results.

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

@@ -63,10 +63,11 @@ sub _initialize {
my ( $self, $tests ) = @_;
my %tests;
while ( my ( $name, $test ) = each %$tests ) {
- $tests{$name} = $self->test_class->new({
- %$test,
- name => $name
- });
+ $tests{$name} = $self->test_class->new(
+ { %$test,
+ name => $name
+ }
+ );
}
$self->tests( \%tests );
return $self;
@@ -170,7 +171,7 @@ sub test {
return $test;
}
else {
- my $test = $self->test_class->new({name => $name});
+ my $test = $self->test_class->new( { name => $name } );
$self->{tests}->{$name} = $test;
return $test;
}
diff --git a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm
index 50e2096..4744086 100644
--- a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm
+++ b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm
@@ -10,11 +10,11 @@ App::Prove::State::Result::Test - Individual test results.

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

@@ -42,6 +42,7 @@ my %methods = (
seq => { method => 'sequence', default => 1 },
total_passes => { method => 'total_passes', default => 0 },
total_failures => { method => 'total_failures', default => 0 },
+ parser => { method => 'parser' },
);

while ( my ( $key, $description ) = each %methods ) {
@@ -132,14 +133,20 @@ The number of times the test has passed.

The number of times the test has failed.

+=head3 C<parser>
+
+The underlying parser object. This is useful if you need the full
+information for the test program.
+
=cut

sub raw {
my $self = shift;
my %raw = %$self;

- # this is backwards-compatibility hack and is not gauranteed.
+ # this is backwards-compatibility hack and is not guaranteed.
delete $raw{name};
+ delete $raw{parser};
return \%raw;
}

diff --git a/ext/Test-Harness/lib/TAP/Base.pm b/ext/Test-Harness/lib/TAP/Base.pm
index 25d4ce2..762d93d 100644
--- a/ext/Test-Harness/lib/TAP/Base.pm
+++ b/ext/Test-Harness/lib/TAP/Base.pm
@@ -9,15 +9,16 @@ use TAP::Object;

=head1 NAME

-TAP::Base - Base class that provides common functionality to L<TAP::Parser> and L<TAP::Harness>
+TAP::Base - Base class that provides common functionality to L<TAP::Parser>
+and L<TAP::Harness>

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

my $GOT_TIME_HIRES;

@@ -51,17 +52,8 @@ C<TAP::Base> provides callback management.

=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 ) = @_;

diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console.pm b/ext/Test-Harness/lib/TAP/Formatter/Base.pm
similarity index 88%
copy from ext/Test-Harness/lib/TAP/Formatter/Console.pm
copy to ext/Test-Harness/lib/TAP/Formatter/Base.pm
index beacf9f..704cfad 100644
--- a/ext/Test-Harness/lib/TAP/Formatter/Console.pm
+++ b/ext/Test-Harness/lib/TAP/Formatter/Base.pm
@@ -1,4 +1,4 @@
-package TAP::Formatter::Console;
+package TAP::Formatter::Base;

use strict;
use TAP::Base ();
@@ -6,12 +6,12 @@ use POSIX qw(strftime);

use vars qw($VERSION @ISA);

-@ISA = qw(TAP::Base);
-
my $MAX_ERRORS = 5;
my %VALIDATION_FOR;

BEGIN {
+ @ISA = qw(TAP::Base);
+
%VALIDATION_FOR = (
directives => sub { shift; shift },
verbosity => sub { shift; shift },
@@ -36,14 +36,7 @@ BEGIN {
_colorizer
);

- for my $method ( @getter_setters, keys %VALIDATION_FOR ) {
- no strict 'refs';
- *$method = sub {
- my $self = shift;
- return $self->{$method} unless @_;
- $self->{$method} = shift;
- };
- }
+ __PACKAGE__->mk_methods( @getter_setters, keys %VALIDATION_FOR );
}

=head1 NAME
@@ -52,11 +45,11 @@ TAP::Formatter::Console - Harness output delegate for default console output

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

@@ -219,7 +212,8 @@ sub _format_now { strftime "[%H:%M:%S]", localtime }
sub _format_name {
my ( $self, $test ) = @_;
my $name = $test;
- my $periods = '.' x ( $self->_longest + 4 - length $test );
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";

if ( $self->timer ) {
my $stamp = $self->_format_now();
@@ -245,27 +239,7 @@ Called to create a new test session. A test session looks like this:
=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,
- show_count => $self->show_count,
- }
- );
-
- $session->header;
-
- return $session;
+ die "Unimplemented.";
}

=head3 C<summary>
@@ -325,6 +299,10 @@ sub summary {
$self->_summary_test_header( $test, $parser );
$self->_failure_output(" Non-zero exit status: $exit\n");
}
+ elsif ( my $wait = $parser->wait ) {
+ $self->_summary_test_header( $test, $parser );
+ $self->_failure_output(" Non-zero wait status: $wait\n");
+ }

if ( my @errors = $parser->parse_errors ) {
my $explain;
@@ -394,26 +372,10 @@ sub _output {
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;
+
+ $self->_output(@_);
}

sub _balanced_range {
diff --git a/ext/Test-Harness/lib/TAP/Formatter/Color.pm b/ext/Test-Harness/lib/TAP/Formatter/Color.pm
index 8558854..36a5b16 100644
--- a/ext/Test-Harness/lib/TAP/Formatter/Color.pm
+++ b/ext/Test-Harness/lib/TAP/Formatter/Color.pm
@@ -71,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

diff --git a/ext/Test-Harness/lib/TAP/Formatter/Console.pm b/ext/Test-Harness/lib/TAP/Formatter/Console.pm
index beacf9f..71cad30 100644
--- a/ext/Test-Harness/lib/TAP/Formatter/Console.pm
+++ b/ext/Test-Harness/lib/TAP/Formatter/Console.pm
@@ -1,50 +1,12 @@
package TAP::Formatter::Console;

use strict;
-use TAP::Base ();
+use TAP::Formatter::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 },
- show_count => 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
- _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;
- };
- }
-}
+@ISA = qw(TAP::Formatter::Base);

=head1 NAME

@@ -52,11 +14,11 @@ TAP::Formatter::Console - Harness output delegate for default console output

=head1 VERSION

-Version 3.14
+Version 3.16

=cut

-$VERSION = '3.14';
+$VERSION = '3.16';

=head1 DESCRIPTION

@@ -67,180 +29,9 @@ This provides console orientated output formatting for TAP::Harness.
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.
-
-=item * C<show_count>
-
-Boolean value. If false, disables the C<X/Y> test count which shows up while
**** PATCH TRUNCATED AT 1000 LINES -- 3133 NOT SHOWN ****

--
Perl5 Master Repository