Skip to content
Browse files

Merge from trunk. Mainly to test subversion 1.5.2 merging - which app…

…ears to work pretty magically :)
  • Loading branch information...
1 parent 07f0d14 commit fe6c781cdf22acc9281b213e1cf533eb0418fd93 @AndyA AndyA committed
Showing with 3,123 additions and 1,432 deletions.
  1. +15 −1 Changes
  2. +13 −0 MANIFEST
  3. +62 −265 META.yml
  4. +9 −1 Makefile.PL
  5. +7 −3 bin/prove
  6. +86 −0 examples/analyze_tests.pl
  7. +1 −1 inc/MyBuilder.pm
  8. +34 −9 lib/App/Prove.pm
  9. +107 −57 lib/App/Prove/State.pm
  10. +233 −0 lib/App/Prove/State/Result.pm
  11. +146 −0 lib/App/Prove/State/Result/Test.pm
  12. +2 −2 lib/TAP/Base.pm
  13. +441 −0 lib/TAP/Formatter/Base.pm
  14. +2 −2 lib/TAP/Formatter/Color.pm
  15. +6 −398 lib/TAP/Formatter/Console.pm
  16. +70 −57 lib/TAP/Formatter/Console/ParallelSession.pm
  17. +25 −149 lib/TAP/Formatter/Console/Session.pm
  18. +58 −0 lib/TAP/Formatter/File.pm
  19. +109 −0 lib/TAP/Formatter/File/Session.pm
  20. +175 −0 lib/TAP/Formatter/Session.pm
  21. +152 −102 lib/TAP/Harness.pm
  22. +23 −2 lib/TAP/Object.pm
  23. +4 −2 lib/TAP/Parser.pm
  24. +6 −3 lib/TAP/Parser/Aggregator.pm
  25. +7 −8 lib/TAP/Parser/Grammar.pm
  26. +2 −2 lib/TAP/Parser/Iterator.pm
  27. +2 −2 lib/TAP/Parser/Iterator/Array.pm
  28. +2 −2 lib/TAP/Parser/Iterator/Process.pm
  29. +2 −2 lib/TAP/Parser/Iterator/Stream.pm
  30. +2 −2 lib/TAP/Parser/IteratorFactory.pm
  31. +2 −2 lib/TAP/Parser/Multiplexer.pm
  32. +7 −5 lib/TAP/Parser/Result.pm
  33. +2 −2 lib/TAP/Parser/Result/Bailout.pm
  34. +2 −2 lib/TAP/Parser/Result/Comment.pm
  35. +2 −2 lib/TAP/Parser/Result/Plan.pm
  36. +2 −2 lib/TAP/Parser/Result/Pragma.pm
  37. +2 −2 lib/TAP/Parser/Result/Test.pm
  38. +2 −2 lib/TAP/Parser/Result/Unknown.pm
  39. +2 −2 lib/TAP/Parser/Result/Version.pm
  40. +2 −2 lib/TAP/Parser/Result/YAML.pm
  41. +2 −2 lib/TAP/Parser/ResultFactory.pm
  42. +96 −27 lib/TAP/Parser/Scheduler.pm
  43. +5 −5 lib/TAP/Parser/Scheduler/Job.pm
  44. +2 −2 lib/TAP/Parser/Scheduler/Spinner.pm
  45. +2 −2 lib/TAP/Parser/Source.pm
  46. +6 −4 lib/TAP/Parser/Source/Perl.pm
  47. +2 −2 lib/TAP/Parser/Utils.pm
  48. +2 −2 lib/TAP/Parser/YAMLish/Reader.pm
  49. +3 −3 lib/TAP/Parser/YAMLish/Writer.pm
  50. +3 −3 lib/Test/Harness.pm
  51. +1 −0 smoke/config.bleep
  52. +1 −0 smoke/config.cygwin
  53. +1 −0 smoke/config.fuzzy
  54. +1 −0 smoke/config.kumina
  55. +1 −0 smoke/config.pickle
  56. +14 −2 smoke/config.surly
  57. +1 −0 smoke/config.tarball
  58. +1 −0 smoke/config.vms
  59. +1 −0 smoke/config.voodoo
  60. +125 −101 smoke/smoke.pl
  61. +3 −1 t/000-load.t
  62. +5 −1 t/aggregator.t
  63. +12 −5 t/compat/failure.t
  64. +2 −2 t/compat/inc_taint.t
  65. +2 −1 t/compat/test-harness-compat.t
  66. +402 −0 t/file.t
  67. +44 −0 t/glob-to-regexp.t
  68. +10 −1 t/grammar.t
  69. +49 −0 t/harness-bailout.t
  70. +75 −0 t/harness-subclass.t
  71. +41 −26 t/harness.t
  72. +7 −2 t/iterators.t
  73. +7 −0 t/lib/NOP.pm
  74. +26 −5 t/multiplexer.t
  75. +2 −2 t/nofork-mux.t
  76. +3 −3 t/nofork.t
  77. +12 −4 t/parse.t
  78. +4 −4 t/parser-config.t
  79. +5 −5 t/parser-subclass.t
  80. +7 −2 t/process.t
  81. +1 −1 t/prove.t
  82. +6 −1 t/proverc.t
  83. +42 −21 t/proverun.t
  84. +5 −1 t/regression.t
  85. +1 −2 t/sample-tests/delayed
  86. +0 −9 t/sample-tests/inc_taint
  87. +0 −5 t/sample-tests/stdout_stderr
  88. +7 −2 t/source.t
  89. +84 −74 t/state.t
  90. +154 −0 t/state_results.t
  91. +7 −2 t/testargs.t
View
16 Changes
@@ -1,8 +1,22 @@
Revision history for Test-Harness
-3.14
+3.15
+ - After discussion with Andy, agreed to clean up the test output
+ somewhat. t/foo.....ok becomes t/foo ... 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.
+
+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.
+ - Added 'fresh' state option to run test scripts that have been
+ touched since the test run.
+ - fixed bug where PERL5OPT was not properly split
+ - fixed regex in _filtered_inc. Fixes #39248. Thanks Slaven.
3.13 2008-07-27
- fixed various closure related leaks
View
13 MANIFEST
@@ -2,6 +2,7 @@ bin/prove
Build.PL
Changes
Changes-2.64
+examples/analyze_tests.pl
examples/bin/forked_tests.pl
examples/bin/test_html.pl
examples/bin/tprove_gtk
@@ -17,11 +18,17 @@ HACKING.pod
inc/MyBuilder.pm
lib/App/Prove.pm
lib/App/Prove/State.pm
+lib/App/Prove/State/Result.pm
+lib/App/Prove/State/Result/Test.pm
lib/TAP/Base.pm
+lib/TAP/Formatter/Base.pm
lib/TAP/Formatter/Color.pm
lib/TAP/Formatter/Console.pm
lib/TAP/Formatter/Console/ParallelSession.pm
lib/TAP/Formatter/Console/Session.pm
+lib/TAP/Formatter/File.pm
+lib/TAP/Formatter/File/Session.pm
+lib/TAP/Formatter/Session.pm
lib/TAP/Harness.pm
lib/TAP/Object.pm
lib/TAP/Parser.pm
@@ -75,7 +82,11 @@ t/data/catme.1
t/data/proverc
t/data/sample.yml
t/errors.t
+t/file.t
+t/glob-to-regexp.t
t/grammar.t
+t/harness-bailout.t
+t/harness-subclass.t
t/harness.t
t/iterators.t
t/lib/App/Prove/Plugin/Dummy.pm
@@ -92,6 +103,7 @@ t/lib/MyResult.pm
t/lib/MyResultFactory.pm
t/lib/MySource.pm
t/lib/NoFork.pm
+t/lib/NOP.pm
t/lib/TAP/Parser/SubclassTest.pm
t/lib/Test/Builder.pm
t/lib/Test/Builder/Module.pm
@@ -176,6 +188,7 @@ t/source_tests/harness_failure
t/source_tests/source
t/spool.t
t/state.t
+t/state_results.t
t/streams.t
t/subclass_tests/non_perl_source
t/subclass_tests/perl_source
View
327 META.yml
@@ -1,18 +1,6 @@
---
name: Test-Harness
-version: 3.14
-
-
-
-
-
-
-
-
-
-
-
-
+version: 3.15
author:
- 'Andy Armstrong C<< <andy@hexten.net> >>'
@@ -31,312 +19,121 @@ recommends:
provides:
App::Prove:
file: lib/App/Prove.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
+ App::Prove::State:
+ file: lib/App/Prove/State.pm
+ version: 3.14
+ App::Prove::State::Result:
+ file: lib/App/Prove/State/Result.pm
+ version: 3.14
+ App::Prove::State::Result::Test:
+ file: lib/App/Prove/State/Result/Test.pm
+ version: 3.14
TAP::Base:
file: lib/TAP/Base.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Formatter::Color:
file: lib/TAP/Formatter/Color.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Formatter::Console:
file: lib/TAP/Formatter/Console.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Formatter::Console::ParallelSession:
file: lib/TAP/Formatter/Console/ParallelSession.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Formatter::Console::Session:
file: lib/TAP/Formatter/Console/Session.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Harness:
file: lib/TAP/Harness.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
+ TAP::Object:
+ file: lib/TAP/Object.pm
+ version: 3.14
TAP::Parser:
file: lib/TAP/Parser.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Aggregator:
file: lib/TAP/Parser/Aggregator.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Grammar:
file: lib/TAP/Parser/Grammar.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Iterator:
file: lib/TAP/Parser/Iterator.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Iterator::Array:
file: lib/TAP/Parser/Iterator/Array.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Iterator::Process:
file: lib/TAP/Parser/Iterator/Process.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Iterator::Stream:
file: lib/TAP/Parser/Iterator/Stream.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
+ TAP::Parser::IteratorFactory:
+ file: lib/TAP/Parser/IteratorFactory.pm
+ version: 3.14
TAP::Parser::Multiplexer:
file: lib/TAP/Parser/Multiplexer.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result:
file: lib/TAP/Parser/Result.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result::Bailout:
file: lib/TAP/Parser/Result/Bailout.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result::Comment:
file: lib/TAP/Parser/Result/Comment.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result::Plan:
file: lib/TAP/Parser/Result/Plan.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
+ TAP::Parser::Result::Pragma:
+ file: lib/TAP/Parser/Result/Pragma.pm
+ version: 3.14
TAP::Parser::Result::Test:
file: lib/TAP/Parser/Result/Test.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result::Unknown:
file: lib/TAP/Parser/Result/Unknown.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result::Version:
file: lib/TAP/Parser/Result/Version.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Result::YAML:
file: lib/TAP/Parser/Result/YAML.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
+ TAP::Parser::ResultFactory:
+ file: lib/TAP/Parser/ResultFactory.pm
+ version: 3.14
+ TAP::Parser::Scheduler:
+ file: lib/TAP/Parser/Scheduler.pm
+ version: 3.14
+ TAP::Parser::Scheduler::Job:
+ file: lib/TAP/Parser/Scheduler/Job.pm
+ version: 3.14
+ TAP::Parser::Scheduler::Spinner:
+ file: lib/TAP/Parser/Scheduler/Spinner.pm
+ version: 3.14
TAP::Parser::Source:
file: lib/TAP/Parser/Source.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::Source::Perl:
file: lib/TAP/Parser/Source/Perl.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
+ TAP::Parser::Utils:
+ file: lib/TAP/Parser/Utils.pm
+ version: 3.14
TAP::Parser::YAMLish::Reader:
file: lib/TAP/Parser/YAMLish/Reader.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
TAP::Parser::YAMLish::Writer:
file: lib/TAP/Parser/YAMLish/Writer.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
Test::Harness:
file: lib/Test/Harness.pm
- version: 3.11
-
-
-
-
-
-
-
-
+ version: 3.14
generated_by: Module::Build version 0.2808
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.2.html
View
10 Makefile.PL
@@ -7,6 +7,8 @@ use ExtUtils::MakeMaker qw/WriteMakefile prompt/;
use strict;
+my $core = grep { $_ eq 'PERL_CORE=1' } @ARGV;
+
my %mm_args = (
'NAME' => 'Test::Harness',
'VERSION_FROM' => 'lib/Test/Harness.pm',
@@ -16,7 +18,13 @@ my %mm_args = (
'INSTALLDIRS' => 'perl',
'PL_FILES' => {},
'test' => { 'TESTS' => 't/*.t t/compat/*.t' },
- 'EXE_FILES' => ['bin/prove'],
+
+ # In the core pods will be built by installman, and prove found by
+ # utils/prove.PL
+ $core
+ ? ( 'MAN3PODS' => {} )
+ : ( 'EXE_FILES' => ['bin/prove'],
+ ),
);
{
View
10 bin/prove
@@ -145,8 +145,7 @@ and can live with the risk.
=head2 C<--state>
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.
+select and/or order the tests to be run based on that saved state.
The C<--state> switch requires an argument which must be a comma
separated list of one or more of the following options.
@@ -227,12 +226,17 @@ Run test tests in fastest to slowest order.
=item C<new>
-Run the tests in newest to oldest order.
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
=item C<old>
Run the tests in oldest to newest order.
+=item C<fresh>
+
+Run those test scripts that have been modified since the last test run.
+
=item C<save>
Save the state on exit. The state is stored in a file called F<.prove>
View
86 examples/analyze_tests.pl
@@ -0,0 +1,86 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use lib 'lib';
+use App::Prove::State;
+use List::Util 'sum';
+use Lingua::EN::Numbers 'num2en';
+use Text::Table;
+use Carp;
+
+sub minutes_and_seconds {
+ my $seconds = shift;
+ return ( int( $seconds / 60 ), int( $seconds % 60 ) );
+}
+
+my $state = App::Prove::State->new( { store => '.prove' } );
+my $results = $state->results;
+my $generation = $results->generation;
+my @tests = $results->tests;
+
+my $total = sum( map { $_->elapsed } @tests );
+my ( $minutes, $seconds ) = minutes_and_seconds($total);
+
+my $num_tests = shift || 10;
+my $total_tests = scalar $results->test_names;
+
+if ( $num_tests > $total_tests ) {
+ $num_tests = $total_tests;
+}
+
+my $num_word = num2en($num_tests);
+
+my %time_for;
+foreach my $test (@tests) {
+ $time_for{ $test->name } = $test->elapsed;
+}
+
+my @sorted_by_time_desc
+ = sort { $time_for{$b} <=> $time_for{$a} } keys %time_for;
+
+print "Number of test programs: $total_tests\n";
+print "Total runtime approximately $minutes minutes $seconds seconds\n\n";
+print "\u$num_word slowest tests:\n";
+
+my @rows;
+for ( 0 .. $num_tests - 1 ) {
+ my $test = $sorted_by_time_desc[$_];
+ my $time = $time_for{$test};
+ my ( $minutes, $seconds ) = minutes_and_seconds($time);
+ push @rows => [ "${minutes}m ${seconds}s", $test, ];
+}
+
+print make_table(
+ [qw/Time Test/],
+ \@rows,
+);
+
+sub make_table {
+ my ( $headers, $rows ) = @_;
+
+ my @rule = qw(- +);
+ my @headers = \'| ';
+ push @headers => map { $_ => \' | ' } @$headers;
+ pop @headers;
+ push @headers => \' |';
+
+ unless ( 'ARRAY' eq ref $rows
+ && 'ARRAY' eq ref $rows->[0]
+ && @$headers == @{ $rows->[0] } )
+ {
+ croak(
+ "make_table() rows must be an AoA with rows being same size as headers"
+ );
+ }
+ my $table = Text::Table->new(@headers);
+ $table->rule(@rule);
+ $table->body_rule(@rule);
+ $table->load(@$rows);
+ return $table->rule(@rule),
+ $table->title,
+ $table->rule(@rule),
+ map( { $table->body($_) } 0 .. @$rows ),
+ $table->rule(@rule);
+}
View
2 inc/MyBuilder.pm
@@ -29,7 +29,7 @@ sub ACTION_test {
require TAP::Harness;
my $harness = TAP::Harness->new( { lib => 'blib/lib' } );
my $aggregator = $harness->runtests(@$tests);
- exit $aggregator->has_problems ? 1 : 0;
+ die "Failed!\n" if $aggregator->has_problems;
}
sub ACTION_testprove {
View
43 lib/App/Prove.pm
@@ -19,11 +19,11 @@ App::Prove - Implements the C<prove> command.
=head1 VERSION
-Version 3.14
+Version 3.15
=cut
-$VERSION = '3.14';
+$VERSION = '3.15';
=head1 DESCRIPTION
@@ -58,7 +58,7 @@ BEGIN {
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
+ test_args state dry extension ignore_exit rules state_manager
);
for my $attr (@ATTR) {
no strict 'refs';
@@ -92,7 +92,6 @@ sub _initialize {
$self->{$key} = [];
}
$self->{harness_class} = 'TAP::Harness';
- $self->{_state} = App::Prove::State->new( { store => STATE_FILE } );
for my $attr (@ATTR) {
if ( exists $args->{$attr} ) {
@@ -109,10 +108,27 @@ 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 } ) );
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.
+
+=head3 C<state_manager>
+
+Getter/setter for the an instane of the C<state_class>.
+
+=cut
+
+sub state_class {
+ return 'App::Prove::State';
+}
+
=head3 C<add_rc_file>
$prove->add_rc_file('myproj/.proverc');
@@ -390,7 +406,6 @@ sub _find_module {
for my $pfx (@search) {
my $name = join( '::', $pfx, $class );
- print "$name\n";
eval "require $name";
return $name unless $@;
}
@@ -431,7 +446,7 @@ command line tool consists of the following code:
my $app = App::Prove->new;
$app->process_args(@ARGV);
- $app->run;
+ exit( $app->run ? 0 : 1 ); # if you need the exit code
=cut
@@ -466,7 +481,7 @@ sub run {
sub _get_tests {
my $self = shift;
- my $state = $self->{_state};
+ my $state = $self->state_manager;
$state->extension( $self->extension );
if ( defined( my $state_switch = $self->state ) ) {
$state->apply_switch(@$state_switch);
@@ -484,15 +499,23 @@ sub _runtests {
my ( $self, $args, $harness_class, @tests ) = @_;
my $harness = $harness_class->new($args);
+ my $state = $self->state_manager;
+
$harness->callback(
after_test => sub {
- $self->{_state}->observe_test(@_);
+ $state->observe_test(@_);
+ }
+ );
+
+ $harness->callback(
+ after_runtests => sub {
+ $state->commit(@_);
}
);
my $aggregator = $harness->runtests(@tests);
- return $aggregator->has_problems ? 0 : 1;
+ return !$aggregator->has_errors;
}
sub _get_switches {
@@ -655,6 +678,8 @@ calling C<run>.
=item C<rules>
+=item C<show_count>
+
=item C<show_help>
=item C<show_man>
View
164 lib/App/Prove/State.pm
@@ -6,6 +6,8 @@ use vars qw($VERSION @ISA);
use File::Find;
use File::Spec;
use Carp;
+
+use App::Prove::State::Result;
use TAP::Parser::YAMLish::Reader ();
use TAP::Parser::YAMLish::Writer ();
use TAP::Base;
@@ -21,11 +23,11 @@ App::Prove::State - State storage for the C<prove> command.
=head1 VERSION
-Version 3.14
+Version 3.15
=cut
-$VERSION = '3.14';
+$VERSION = '3.15';
=head1 DESCRIPTION
@@ -54,10 +56,11 @@ sub new {
my %args = %{ shift || {} };
my $self = bless {
- _ => {
- tests => {},
- generation => 1
- },
+ _ => $class->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ ),
select => [],
seq => 1,
store => delete $args{store},
@@ -71,6 +74,18 @@ sub new {
return $self;
}
+=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
+identical interface.
+
+=cut
+
+sub result_class {
+ return 'App::Prove::State::Result';
+}
+
=head2 C<extension>
Get or set the extension map hash. Keys in the hash correspond
@@ -86,7 +101,24 @@ sub extension {
return $self->{extension};
}
-sub DESTROY {
+=head2 C<results>
+
+Get the results of the last test run. Returns a C<result_class()> instance.
+
+=cut
+
+sub results {
+ my $self = shift;
+ $self->{_} || $self->result_class->new;
+}
+
+=head2 C<commit>
+
+Save the test results. Should be called after all tests have run.
+
+=cut
+
+sub commit {
my $self = shift;
if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
$self->save($store);
@@ -153,53 +185,57 @@ sub apply_switch {
my $self = shift;
my @opts = @_;
- my $last_gen = $self->{_}->{generation} - 1;
- my $now = $self->get_time;
+ my $last_gen = $self->results->generation - 1;
+ my $last_run_time = $self->results->last_run_time;
+ my $now = $self->get_time;
my @switches = map { split /,/ } @opts;
my %handler = (
last => sub {
$self->_select(
- where => sub { $_->{gen} >= $last_gen },
- order => sub { $_->{seq} }
+ where => sub { $_->generation >= $last_gen },
+ order => sub { $_->sequence }
);
},
failed => sub {
$self->_select(
- where => sub { $_->{last_result} != 0 },
- order => sub { -$_->{last_result} }
+ where => sub { $_->result != 0 },
+ order => sub { -$_->result }
);
},
passed => sub {
- $self->_select( where => sub { $_->{last_result} == 0 } );
+ $self->_select( where => sub { $_->result == 0 } );
},
all => sub {
$self->_select();
},
todo => sub {
$self->_select(
- where => sub { $_->{last_todo} != 0 },
- order => sub { -$_->{last_todo}; }
+ where => sub { $_->num_todo != 0 },
+ order => sub { -$_->num_todo; }
);
},
hot => sub {
$self->_select(
- where => sub { defined $_->{last_fail_time} },
- order => sub { $now - $_->{last_fail_time} }
+ where => sub { defined $_->last_fail_time },
+ order => sub { $now - $_->last_fail_time }
);
},
slow => sub {
- $self->_select( order => sub { -$_->{elapsed} } );
+ $self->_select( order => sub { -$_->elapsed } );
},
fast => sub {
- $self->_select( order => sub { $_->{elapsed} } );
+ $self->_select( order => sub { $_->elapsed } );
},
new => sub {
- $self->_select( order => sub { -$_->{mtime} } );
+ $self->_select( order => sub { -$_->mtime } );
},
old => sub {
- $self->_select( order => sub { $_->{mtime} } );
+ $self->_select( order => sub { $_->mtime } );
+ },
+ fresh => sub {
+ $self->_select( where => sub { $_->mtime >= $last_run_time } );
},
save => sub {
$self->{should_save}++;
@@ -253,7 +289,7 @@ sub _query {
my $self = shift;
if ( my @sel = @{ $self->{select} } ) {
warn "No saved state, selection will be empty\n"
- unless keys %{ $self->{_}->{tests} };
+ unless $self->results->num_tests;
return map { $self->_query_clause($_) } @sel;
}
return;
@@ -262,14 +298,14 @@ sub _query {
sub _query_clause {
my ( $self, $clause ) = @_;
my @got;
- my $tests = $self->{_}->{tests};
+ my $results = $self->results;
my $where = $clause->{where} || sub {1};
# Select
- for my $test ( sort keys %$tests ) {
- next unless -f $test;
- local $_ = $tests->{$test};
- push @got, $test if $where->();
+ for my $name ( $results->test_names ) {
+ next unless -f $name;
+ local $_ = $results->test($name);
+ push @got, $name if $where->();
}
# Sort
@@ -280,7 +316,7 @@ sub _query_clause {
|| ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
} map {
[ $_,
- do { local $_ = $tests->{$_}; $order->() }
+ do { local $_ = $results->test($_); $order->() }
]
} @got;
}
@@ -357,8 +393,9 @@ Store the results of a test.
sub observe_test {
my ( $self, $test, $parser ) = @_;
$self->_record_test(
- $test, scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
- scalar( $parser->todo ), $parser->start_time, $parser->end_time
+ $test->[0],
+ scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ),
+ scalar( $parser->todo ), $parser->start_time, $parser->end_time,
);
}
@@ -373,24 +410,24 @@ sub observe_test {
# state generation
sub _record_test {
- my ( $self, $test, $fail, $todo, $start_time, $end_time ) = @_;
- my $rec = $self->{_}->{tests}->{ $test->[0] } ||= {};
+ my ( $self, $name, $fail, $todo, $start_time, $end_time ) = @_;
+ my $test = $self->results->test($name);
- $rec->{seq} = $self->{seq}++;
- $rec->{gen} = $self->{_}->{generation};
+ $test->sequence( $self->{seq}++ );
+ $test->generation( $self->results->generation );
- $rec->{last_run_time} = $end_time;
- $rec->{last_result} = $fail;
- $rec->{last_todo} = $todo;
- $rec->{elapsed} = $end_time - $start_time;
+ $test->run_time($end_time);
+ $test->result($fail);
+ $test->num_todo($todo);
+ $test->elapsed( $end_time - $start_time );
if ($fail) {
- $rec->{total_failures}++;
- $rec->{last_fail_time} = $end_time;
+ $test->total_failures( $test->total_failures + 1 );
+ $test->last_fail_time($end_time);
}
else {
- $rec->{total_passes}++;
- $rec->{last_pass_time} = $end_time;
+ $test->total_passes( $test->total_passes + 1 );
+ $test->last_pass_time($end_time);
}
}
@@ -402,10 +439,13 @@ Write the state to a file.
sub save {
my ( $self, $name ) = @_;
+
+ $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 ($!)";
- $writer->write( $self->{_} || {}, \*FH );
+ $writer->write( $self->results->raw, \*FH );
close FH;
}
@@ -420,37 +460,47 @@ sub load {
my $reader = TAP::Parser::YAMLish::Reader->new;
local *FH;
open FH, "<$name" or croak "Can't read $name ($!)";
- $self->{_} = $reader->read(
- sub {
- my $line = <FH>;
- defined $line && chomp $line;
- return $line;
- }
+
+ # XXX this is temporary
+ $self->{_} = $self->result_class->new(
+ $reader->read(
+ sub {
+ my $line = <FH>;
+ defined $line && chomp $line;
+ return $line;
+ }
+ )
);
# $writer->write( $self->{tests} || {}, \*FH );
close FH;
$self->_regen_seq;
$self->_prune_and_stamp;
- $self->{_}->{generation}++;
+ $self->results->generation( $self->results->generation + 1 );
}
sub _prune_and_stamp {
my $self = shift;
- for my $name ( keys %{ $self->{_}->{tests} || {} } ) {
+
+ my $results = $self->results;
+ my @tests = $self->results->tests;
+ for my $test (@tests) {
+ my $name = $test->name;
if ( my @stat = stat $name ) {
- $self->{_}->{tests}->{$name}->{mtime} = $stat[9];
+ $test->mtime( $stat[9] );
}
else {
- delete $self->{_}->{tests}->{$name};
+ $results->remove($name);
}
}
}
sub _regen_seq {
my $self = shift;
- for my $rec ( values %{ $self->{_}->{tests} || {} } ) {
- $self->{seq} = $rec->{seq} + 1
- if defined $rec->{seq} && $rec->{seq} >= $self->{seq};
+ for my $test ( $self->results->tests ) {
+ $self->{seq} = $test->sequence + 1
+ if defined $test->sequence && $test->sequence >= $self->{seq};
}
}
+
+1;
View
233 lib/App/Prove/State/Result.pm
@@ -0,0 +1,233 @@
+package App::Prove::State::Result;
+
+use strict;
+use Carp 'croak';
+
+use App::Prove::State::Result::Test;
+use vars qw($VERSION);
+
+use constant STATE_VERSION => 1;
+
+=head1 NAME
+
+App::Prove::State::Result - Individual test suite results.
+
+=head1 VERSION
+
+Version 3.15
+
+=cut
+
+$VERSION = '3.15';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test suite run.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $result = App::Prove::State::Result->new({
+ generation => $generation,
+ tests => \%tests,
+ });
+
+Returns a new C<App::Prove::State::Result> instance.
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ my %instance_data = %$arg_for; # shallow copy
+ $instance_data{version} = $class->state_version;
+ my $tests = delete $instance_data{tests} || {};
+ my $self = bless \%instance_data => $class;
+ $self->_initialize($tests);
+ return $self;
+}
+
+sub _initialize {
+ my ( $self, $tests ) = @_;
+ my %tests;
+ while ( my ( $name, $test ) = each %$tests ) {
+ $tests{$name} = $self->test_class->new(
+ { %$test,
+ name => $name
+ }
+ );
+ }
+ $self->tests( \%tests );
+ return $self;
+}
+
+=head2 C<state_version>
+
+Returns the current version of state storage.
+
+=cut
+
+sub state_version {STATE_VERSION}
+
+=head2 C<test_class>
+
+Returns the name of the class used for tracking individual tests. This class
+should either subclass from C<App::Prove::State::Result::Test> or provide an
+identical interface.
+
+=cut
+
+sub test_class {
+ return 'App::Prove::State::Result::Test';
+}
+
+my %methods = (
+ generation => { method => 'generation', default => 0 },
+ last_run_time => { method => 'last_run_time', default => undef },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head3 C<generation>
+
+Getter/setter for the "generation" of the test suite run. The first
+generation is 1 (one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_run_time>
+
+Getter/setter for the time of the test suite run.
+
+=head3 C<tests>
+
+Returns the tests for a given generation. This is a hashref or a hash,
+depending on context called. The keys to the hash are the individual
+test names and the value is a hashref with various interesting values.
+Each k/v pair might resemble something like this:
+
+ 't/foo.t' => {
+ elapsed => '0.0428488254547119',
+ gen => '7',
+ last_pass_time => '1219328376.07815',
+ last_result => '0',
+ last_run_time => '1219328376.07815',
+ last_todo => '0',
+ mtime => '1191708862',
+ seq => '192',
+ total_passes => '6',
+ }
+
+=cut
+
+sub tests {
+ my $self = shift;
+ if (@_) {
+ $self->{tests} = shift;
+ return $self;
+ }
+ my %tests = %{ $self->{tests} };
+ my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
+ return wantarray ? @tests : \@tests;
+}
+
+=head3 C<test>
+
+ my $test = $result->test('t/customer/create.t');
+
+Returns an individual C<App::Prove::State::Result::Test> instance for the
+given test name (usually the filename). Will return a new
+C<App::Prove::State::Result::Test> instance if the name is not found.
+
+=cut
+
+sub test {
+ my ( $self, $name ) = @_;
+ croak("test() requires a test name") unless defined $name;
+
+ my $tests = $self->{tests} ||= {};
+ if ( my $test = $tests->{$name} ) {
+ return $test;
+ }
+ else {
+ my $test = $self->test_class->new( { name => $name } );
+ $self->{tests}->{$name} = $test;
+ return $test;
+ }
+}
+
+=head3 C<test_names>
+
+Returns an list of test names, sorted by run order.
+
+=cut
+
+sub test_names {
+ my $self = shift;
+ return map { $_->name } $self->tests;
+}
+
+=head3 C<remove>
+
+ $result->remove($test_name); # remove the test
+ my $test = $result->test($test_name); # fatal error
+
+Removes a given test from results. This is a no-op if the test name is not
+found.
+
+=cut
+
+sub remove {
+ my ( $self, $name ) = @_;
+ delete $self->{tests}->{$name};
+ return $self;
+}
+
+=head3 C<num_tests>
+
+Returns the number of tests for a given test suite result.
+
+=cut
+
+sub num_tests { keys %{ shift->{tests} } }
+
+=head3 C<raw>
+
+Returns a hashref of raw results, suitable for serialization by YAML.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ my %tests;
+ foreach my $test ( $self->tests ) {
+ $tests{ $test->name } = $test->raw;
+ }
+ $raw{tests} = \%tests;
+ return \%raw;
+}
+
+1;
View
146 lib/App/Prove/State/Result/Test.pm
@@ -0,0 +1,146 @@
+package App::Prove::State::Result::Test;
+
+use strict;
+
+use vars qw($VERSION);
+
+=head1 NAME
+
+App::Prove::State::Result::Test - Individual test results.
+
+=head1 VERSION
+
+Version 3.15
+
+=cut
+
+$VERSION = '3.15';
+
+=head1 DESCRIPTION
+
+The C<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+my %methods = (
+ name => { method => 'name' },
+ elapsed => { method => 'elapsed', default => 0 },
+ gen => { method => 'generation', default => 1 },
+ last_pass_time => { method => 'last_pass_time', default => undef },
+ last_fail_time => { method => 'last_fail_time', default => undef },
+ last_result => { method => 'result', default => 0 },
+ last_run_time => { method => 'run_time', default => undef },
+ last_todo => { method => 'num_todo', default => 0 },
+ mtime => { method => 'mtime', default => undef },
+ seq => { method => 'sequence', default => 1 },
+ total_passes => { method => 'total_passes', default => 0 },
+ total_failures => { method => 'total_failures', default => 0 },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ bless $arg_for => $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<name>
+
+The name of the test. Usually a filename.
+
+=head3 C<elapsed>
+
+The total elapsed times the test took to run, in seconds from the epoch..
+
+=head3 C<generation>
+
+The number for the "generation" of the test run. The first generation is 1
+(one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_pass_time>
+
+The last time the test program passed, in seconds from the epoch.
+
+Returns C<undef> if the program has never passed.
+
+=head3 C<last_fail_time>
+
+The last time the test suite failed, in seconds from the epoch.
+
+Returns C<undef> if the program has never failed.
+
+=head3 C<mtime>
+
+Returns the mtime of the test, in seconds from the epoch.
+
+=head3 C<raw>
+
+Returns a hashref of raw test data, suitable for serialization by YAML.
+
+=head3 C<result>
+
+Currently, whether or not the test suite passed with no 'problems' (such as
+TODO passed).
+
+=head3 C<run_time>
+
+The total time it took for the test to run, in seconds. If C<Time::HiRes> is
+available, it will have finer granularity.
+
+=head3 C<num_todo>
+
+The number of tests with TODO directives.
+
+=head3 C<sequence>
+
+The order in which this test was run for the given test suite result.
+
+=head3 C<total_passes>
+
+The number of times the test has passed.
+
+=head3 C<total_failures>
+
+The number of times the test has failed.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ # this is backwards-compatibility hack and is not gauranteed.
+ delete $raw{name};
+ return \%raw;
+}
+
+1;
View
4 lib/TAP/Base.pm
@@ -13,11 +13,11 @@ TAP::Base - Base class that provides common functionality to L<TAP::Parser> and
=head1 VERSION
-Version 3.14
+Version 3.15
=cut
-$VERSION = '3.14';
+$VERSION = '3.15';
my $GOT_TIME_HIRES;
View
441 lib/TAP/Formatter/Base.pm
@@ -0,0 +1,441 @@
+package TAP::Formatter::Base;
+
+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 },
+ 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;
+ };
+ }
+}
+
+=head1 NAME
+
+TAP::Formatter::Console - Harness output delegate for default console output
+
+=head1 VERSION
+
+Version 3.15
+
+=cut
+
+$VERSION = '3.15';
+
+=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.
+
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
+=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.
+
+This is an advisory and may not be called in the case where tests are
+being supplied to Test::Harness by an iterator.
+
+=cut
+
+sub prepare {
+ my ( $self, @tests ) = @_;
+
+ my $longest = 0;
+
+ foreach my $test (@tests) {
+ $longest = length $test if length $test > $longest;
+ }
+
+ $self->_longest($longest);
+}
+
+sub _format_now { strftime "[%H:%M:%S]", localtime }
+
+sub _format_name {
+ my ( $self, $test ) = @_;
+ my $name = $test;
+ my $periods = '.' x ( $self->_longest + 2 - length $test );
+ $periods = " $periods ";
+
+ 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 {
+ die "Unimplemented.";
+}
+
+=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: ', ' Failed tests: ' ],
+ $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 ( my @r = $parser->$method() ) {
+ $self->_summary_test_header( $test, $parser );
+ my ( $singular, $plural )
+ = 'ARRAY' eq ref $name ? @$name : ( $name, $name );
+ $self->$output( @r == 1 ? $singular : $plural );
+ my @results = $self->_balanced_range( 40, @r );
+ $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 } @_;
+}
+
+sub _failure_output {
+ my $self = shift;
+
+ $self->_output(@_);
+}
+
+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;
View
4 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.15
=cut
-$VERSION = '3.14';
+$VERSION = '3.15';
=head1 DESCRIPTION
View
404 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.15
=cut
-$VERSION = '3.14';
+$VERSION = '3.15';
=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
-tests are running.
-