From 27fc0087fcbd5bf6e1c752f006de35a91d34d354 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Sat, 13 Sep 2008 15:25:35 +0000 Subject: [PATCH] Upgrade to Test::Harness 3.14 p4raw-id: //depot/perl@34359 --- MANIFEST | 6 + ext/Test/Harness/Changes | 10 + ext/Test/Harness/Makefile.PL | 8 +- ext/Test/Harness/bin/prove | 12 +- ext/Test/Harness/lib/App/Prove.pm | 60 ++++-- ext/Test/Harness/lib/App/Prove/State.pm | 169 +++++++++------ ext/Test/Harness/lib/App/Prove/State/Result.pm | 232 +++++++++++++++++++++ .../Harness/lib/App/Prove/State/Result/Test.pm | 146 +++++++++++++ ext/Test/Harness/lib/TAP/Base.pm | 4 +- ext/Test/Harness/lib/TAP/Formatter/Color.pm | 4 +- ext/Test/Harness/lib/TAP/Formatter/Console.pm | 17 +- .../lib/TAP/Formatter/Console/ParallelSession.pm | 127 ++++++----- .../Harness/lib/TAP/Formatter/Console/Session.pm | 49 +++-- ext/Test/Harness/lib/TAP/Harness.pm | 219 +++++++++++-------- ext/Test/Harness/lib/TAP/Object.pm | 25 ++- ext/Test/Harness/lib/TAP/Parser.pm | 6 +- ext/Test/Harness/lib/TAP/Parser/Aggregator.pm | 4 +- ext/Test/Harness/lib/TAP/Parser/Grammar.pm | 15 +- ext/Test/Harness/lib/TAP/Parser/Iterator.pm | 4 +- ext/Test/Harness/lib/TAP/Parser/Iterator/Array.pm | 4 +- .../Harness/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 | 123 ++++++++--- ext/Test/Harness/lib/TAP/Parser/Scheduler/Job.pm | 10 +- .../Harness/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 | 10 +- 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 | 6 +- ext/Test/Harness/lib/Test/Harness.pm | 6 +- ext/Test/Harness/t/000-load.t | 4 +- ext/Test/Harness/t/compat/failure.t | 15 +- ext/Test/Harness/t/compat/test-harness-compat.t | 130 ++++++------ ext/Test/Harness/t/glob-to-regexp.t | 44 ++++ ext/Test/Harness/t/harness-subclass.t | 75 +++++++ ext/Test/Harness/t/harness.t | 21 +- ext/Test/Harness/t/iterators.t | 9 +- ext/Test/Harness/t/lib/NOP.pm | 7 + ext/Test/Harness/t/multiplexer.t | 33 ++- ext/Test/Harness/t/nofork.t | 4 +- ext/Test/Harness/t/parse.t | 9 +- ext/Test/Harness/t/process.t | 9 +- ext/Test/Harness/t/prove.t | 211 ++++++++++++------- ext/Test/Harness/t/proverc.t | 7 +- ext/Test/Harness/t/proverun.t | 63 ++++-- ext/Test/Harness/t/regression.t | 8 +- ext/Test/Harness/t/sample-tests/delayed | 6 - ext/Test/Harness/t/sample-tests/inc_taint | 9 - ext/Test/Harness/t/sample-tests/stdout_stderr | 5 - ext/Test/Harness/t/source.t | 9 +- ext/Test/Harness/t/state.t | 156 +++++++------- ext/Test/Harness/t/state_results.t | 154 ++++++++++++++ ext/Test/Harness/t/testargs.t | 9 +- 66 files changed, 1726 insertions(+), 627 deletions(-) create mode 100644 ext/Test/Harness/lib/App/Prove/State/Result.pm create mode 100644 ext/Test/Harness/lib/App/Prove/State/Result/Test.pm create mode 100644 ext/Test/Harness/t/glob-to-regexp.t create mode 100644 ext/Test/Harness/t/harness-subclass.t create mode 100644 ext/Test/Harness/t/lib/NOP.pm create mode 100644 ext/Test/Harness/t/state_results.t diff --git a/MANIFEST b/MANIFEST index 2872eeb..7eaab54 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1125,6 +1125,8 @@ ext/Test/Harness/bin/prove The prove harness utility ext/Test/Harness/Changes Test::Harness change log ext/Test/Harness/lib/App/Prove.pm Gubbins for the prove utility 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/Color.pm A parser for Test Anything Protocol ext/Test/Harness/lib/TAP/Formatter/Console/ParallelSession.pm A parser for Test Anything Protocol @@ -1179,7 +1181,9 @@ 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/glob-to-regexp.t Test::Harness test ext/Test/Harness/t/grammar.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 @@ -1195,6 +1199,7 @@ ext/Test/Harness/t/lib/MyResultFactory.pm Module for testing Test::Harness ext/Test/Harness/t/lib/MyResult.pm Module for testing Test::Harness ext/Test/Harness/t/lib/MySource.pm Module for testing Test::Harness ext/Test/Harness/t/lib/NoFork.pm Module for testing Test::Harness +ext/Test/Harness/t/lib/NOP.pm Module for testing Test::Harness ext/Test/Harness/t/lib/TAP/Parser/SubclassTest.pm Module for testing Test::Harness ext/Test/Harness/t/multiplexer.t Test::Harness test ext/Test/Harness/t/nofork-mux.t Test::Harness test @@ -1274,6 +1279,7 @@ ext/Test/Harness/t/source_tests/harness_directives Test data for Test::Harness ext/Test/Harness/t/source_tests/harness_failure Test data for Test::Harness ext/Test/Harness/t/source_tests/source Test data for Test::Harness ext/Test/Harness/t/spool.t Test::Harness test +ext/Test/Harness/t/state_results.t Test::Harness test ext/Test/Harness/t/state.t Test::Harness test ext/Test/Harness/t/streams.t Test::Harness test ext/Test/Harness/t/subclass_tests/non_perl_source Test data for Test::Harness diff --git a/ext/Test/Harness/Changes b/ext/Test/Harness/Changes index 2051eab..4ae9f1d 100644 --- a/ext/Test/Harness/Changes +++ b/ext/Test/Harness/Changes @@ -1,5 +1,15 @@ Revision history for Test-Harness + +3.14 + - 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 - made prove honour HARNESS_TIMER diff --git a/ext/Test/Harness/Makefile.PL b/ext/Test/Harness/Makefile.PL index e6e34c3..6bc533c 100644 --- a/ext/Test/Harness/Makefile.PL +++ b/ext/Test/Harness/Makefile.PL @@ -18,12 +18,12 @@ my %mm_args = ( 'INSTALLDIRS' => 'perl', 'PL_FILES' => {}, 'test' => { 'TESTS' => 't/*.t t/compat/*.t' }, + # In the core pods will be built by installman, and prove found by # utils/prove.PL - $core ? ( - 'MAN3PODS' => {} - ) : ( - 'EXE_FILES' => ['bin/prove'], + $core + ? ( 'MAN3PODS' => {} ) + : ( 'EXE_FILES' => ['bin/prove'], ), ); diff --git a/ext/Test/Harness/bin/prove b/ext/Test/Harness/bin/prove index ee31df8..01df160 100644 --- a/ext/Test/Harness/bin/prove +++ b/ext/Test/Harness/bin/prove @@ -27,6 +27,8 @@ Boolean options: -s, --shuffle Run the tests in random order. -c, --color Colored test output (default). --nocolor Do not color test output. + --count Show the X/Y test count when not verbose (default) + --nocount Disable the X/Y test count. -D --dry Dry run. Show test that would have run. --ext Set the extension for tests (default '.t') -f, --failures Only show failed tests. @@ -143,8 +145,7 @@ and can live with the risk. =head2 C<--state> You can ask C 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. @@ -225,12 +226,17 @@ Run test tests in fastest to slowest order. =item C -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 Run the tests in oldest to newest order. +=item C + +Run those test scripts that have been modified since the last test run. + =item C Save the state on exit. The state is stored in a file called F<.prove> diff --git a/ext/Test/Harness/lib/App/Prove.pm b/ext/Test/Harness/lib/App/Prove.pm index b68ca40..29d2f8f 100644 --- a/ext/Test/Harness/lib/App/Prove.pm +++ b/ext/Test/Harness/lib/App/Prove.pm @@ -19,11 +19,11 @@ App::Prove - Implements the C command. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION @@ -54,18 +54,18 @@ my @ATTR; BEGIN { @ATTR = qw( - archive argv blib color directives exec failures fork formatter - harness includes modules plugins jobs lib merge parse quiet + 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 + verbose warnings_fail warnings_warn show_help show_man show_version + test_args state dry extension ignore_exit rules state_manager ); for my $attr (@ATTR) { no strict 'refs'; *$attr = sub { my $self = shift; - croak "$attr is read-only" if @_; - $self->{$attr}; + $self->{$attr} = shift if @_; + return $self->{$attr}; }; } } @@ -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 + +Returns the name of the class used for maintaining state. This class should +either subclass from C or provide an identical interface. + +=head3 C + +Getter/setter for the an instane of the C. + +=cut + +sub state_class { + return 'App::Prove::State'; +} + =head3 C $prove->add_rc_file('myproj/.proverc'); @@ -202,6 +218,7 @@ sub process_args { 's|shuffle' => \$self->{shuffle}, 'color!' => \$self->{color}, 'colour!' => \$self->{color}, + 'count!' => \$self->{show_count}, 'c' => \$self->{color}, 'D|dry' => \$self->{dry}, 'ext=s' => \$self->{extension}, @@ -278,6 +295,12 @@ sub _get_args { if ( defined $self->color ? $self->color : $self->_color_default ) { $args{color} = 1; } + if ( !defined $self->show_count ) { + $args{show_count} = 1; + } + else { + $args{show_count} = $self->show_count; + } if ( $self->archive ) { $self->require_harness( archive => 'TAP::Harness::Archive' ); @@ -367,7 +390,6 @@ sub _find_module { for my $pfx (@search) { my $name = join( '::', $pfx, $class ); - print "$name\n"; eval "require $name"; return $name unless $@; } @@ -408,7 +430,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 @@ -443,7 +465,7 @@ sub run { sub _get_tests { my $self = shift; - my $state = $self->{_state}; + my $state = $self->state_manager; my $ext = $self->extension; $state->extension($ext) if defined $ext; if ( defined( my $state_switch = $self->state ) ) { @@ -462,15 +484,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 { @@ -633,6 +663,8 @@ calling C. =item C +=item C + =item C =item C diff --git a/ext/Test/Harness/lib/App/Prove/State.pm b/ext/Test/Harness/lib/App/Prove/State.pm index aeac643..2b284d2 100644 --- a/ext/Test/Harness/lib/App/Prove/State.pm +++ b/ext/Test/Harness/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 command. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =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 + +Returns the name of the class used for tracking test results. This class +should either subclass from C or provide an +identical interface. + +=cut + +sub result_class { + return 'App::Prove::State::Result'; +} + =head2 C Get or set the extension files must have in order to be considered @@ -84,7 +99,24 @@ sub extension { return $self->{extension}; } -sub DESTROY { +=head2 C + +Get the results of the last test run. Returns a C instance. + +=cut + +sub results { + my $self = shift; + $self->{_} || $self->result_class->new +} + +=head2 C + +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); @@ -151,53 +183,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}++; @@ -251,7 +287,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; @@ -260,14 +296,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 @@ -278,7 +314,7 @@ sub _query_clause { || ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) ) } map { [ $_, - do { local $_ = $tests->{$_}; $order->() } + do { local $_ = $results->test($_); $order->() } ] } @got; } @@ -318,8 +354,9 @@ sub _expand_dir_recursive { my @tests; find( - { follow => 1, #21938 - wanted => sub { + { follow => 1, #21938 + follow_skip => 2, + wanted => sub { -f && /\Q$extension\E$/ && push @tests => $File::Find::name; @@ -339,8 +376,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, ); } @@ -355,24 +393,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); } } @@ -384,10 +422,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; } @@ -402,37 +443,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 = ; - defined $line && chomp $line; - return $line; - } + + # XXX this is temporary + $self->{_} = $self->result_class->new( + $reader->read( + sub { + my $line = ; + 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; diff --git a/ext/Test/Harness/lib/App/Prove/State/Result.pm b/ext/Test/Harness/lib/App/Prove/State/Result.pm new file mode 100644 index 0000000..37337ea --- /dev/null +++ b/ext/Test/Harness/lib/App/Prove/State/Result.pm @@ -0,0 +1,232 @@ +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.14 + +=cut + +$VERSION = '3.14'; + +=head1 DESCRIPTION + +The C 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 + + my $result = App::Prove::State::Result->new({ + generation => $generation, + tests => \%tests, + }); + +Returns a new C 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 + +Returns the current version of state storage. + +=cut + +sub state_version {STATE_VERSION} + +=head2 C + +Returns the name of the class used for tracking individual tests. This class +should either subclass from C 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 + +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 + +Getter/setter for the time of the test suite run. + +=head3 C + +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 + + my $test = $result->test('t/customer/create.t'); + +Returns an individual C instance for the +given test name (usually the filename). Will return a new +C 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 + +Returns an list of test names, sorted by run order. + +=cut + +sub test_names { + my $self = shift; + return map { $_->name } $self->tests; +} + +=head3 C + + $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 + +Returns the number of tests for a given test suite result. + +=cut + +sub num_tests { keys %{ shift->{tests} } } + +=head3 C + +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; diff --git a/ext/Test/Harness/lib/App/Prove/State/Result/Test.pm b/ext/Test/Harness/lib/App/Prove/State/Result/Test.pm new file mode 100644 index 0000000..50e2096 --- /dev/null +++ b/ext/Test/Harness/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.14 + +=cut + +$VERSION = '3.14'; + +=head1 DESCRIPTION + +The C 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 + +=cut + +sub new { + my ( $class, $arg_for ) = @_; + $arg_for ||= {}; + bless $arg_for => $class; +} + +=head2 Instance Methods + +=head3 C + +The name of the test. Usually a filename. + +=head3 C + +The total elapsed times the test took to run, in seconds from the epoch.. + +=head3 C + +The number for the "generation" of the test run. The first generation is 1 +(one) and subsequent generations are 2, 3, etc. + +=head3 C + +The last time the test program passed, in seconds from the epoch. + +Returns C if the program has never passed. + +=head3 C + +The last time the test suite failed, in seconds from the epoch. + +Returns C if the program has never failed. + +=head3 C + +Returns the mtime of the test, in seconds from the epoch. + +=head3 C + +Returns a hashref of raw test data, suitable for serialization by YAML. + +=head3 C + +Currently, whether or not the test suite passed with no 'problems' (such as +TODO passed). + +=head3 C + +The total time it took for the test to run, in seconds. If C is +available, it will have finer granularity. + +=head3 C + +The number of tests with TODO directives. + +=head3 C + +The order in which this test was run for the given test suite result. + +=head3 C + +The number of times the test has passed. + +=head3 C + +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; diff --git a/ext/Test/Harness/lib/TAP/Base.pm b/ext/Test/Harness/lib/TAP/Base.pm index 0745034..25d4ce2 100644 --- a/ext/Test/Harness/lib/TAP/Base.pm +++ b/ext/Test/Harness/lib/TAP/Base.pm @@ -13,11 +13,11 @@ TAP::Base - Base class that provides common functionality to L and =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; my $GOT_TIME_HIRES; diff --git a/ext/Test/Harness/lib/TAP/Formatter/Color.pm b/ext/Test/Harness/lib/TAP/Formatter/Color.pm index 532f279..8558854 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.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Formatter/Console.pm b/ext/Test/Harness/lib/TAP/Formatter/Console.pm index 05384f0..beacf9f 100644 --- a/ext/Test/Harness/lib/TAP/Formatter/Console.pm +++ b/ext/Test/Harness/lib/TAP/Formatter/Console.pm @@ -20,6 +20,7 @@ BEGIN { 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") @@ -51,11 +52,11 @@ TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION @@ -179,6 +180,11 @@ the current platform and output is not being redirected. The number of concurrent jobs this formatter will handle. +=item * C + +Boolean value. If false, disables the C test count which shows up while +tests are running. + =back Any keys for which the value is C will be ignored. @@ -250,9 +256,10 @@ sub open_test { $self->_croak($@) if $@; my $session = $class->new( - { name => $test, - formatter => $self, - parser => $parser + { name => $test, + formatter => $self, + parser => $parser, + show_count => $self->show_count, } ); diff --git a/ext/Test/Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/ext/Test/Harness/lib/TAP/Formatter/Console/ParallelSession.pm index a509cf7..eae6598 100644 --- a/ext/Test/Harness/lib/TAP/Formatter/Console/ParallelSession.pm +++ b/ext/Test/Harness/lib/TAP/Formatter/Console/ParallelSession.pm @@ -36,27 +36,22 @@ sub _create_shared_context { }; } -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.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION -This provides console orientated output formatting for L. +This provides console orientated output formatting for L +when run with multiple L. =head1 SYNOPSIS @@ -73,28 +68,49 @@ Output test preamble =cut sub header { - my $self = shift; - $self->_need_refresh; -} - -sub _refresh { } -sub _clear_line { +sub _clear_ruler { my $self = shift; $self->formatter->_output( "\r" . ( ' ' x WIDTH ) . "\r" ); } +my $now = 0; +my $start; + +my $trailer = '... )==='; +my $chop_length = WIDTH - length $trailer; + sub _output_ruler { - my $self = shift; + my ($self, $refresh) = @_; + my $new_now = time; + return if $new_now == $now and !$refresh; + $now = $new_now; + $start ||= $now; 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"); + my $ruler = sprintf '===( %7d;%d ', $context->{tests}, $now - $start; + + foreach my $active ( @{$context->{active}} ) { + my $parser = $active->parser; + my $tests = $parser->tests_run; + my $planned = $parser->tests_planned || '?'; + + $ruler .= sprintf '%' . length ($planned) . "d/$planned ", $tests; + } + chop $ruler; # Remove a trailing space + $ruler .= ')==='; + + if ( length $ruler > WIDTH ) { + $ruler =~ s/(.{$chop_length}).*/$1$trailer/o; + } + else { + $ruler .= '=' x ( WIDTH - length( $ruler ) ); + } + $formatter->_output( "\r$ruler"); } =head3 C @@ -105,33 +121,45 @@ sub _output_ruler { 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 ) { + if ( $result->is_test ) { + my $context = $shared{$formatter}; + $context->{tests}++; + + my $active = $context->{active}; + if ( @$active == 1 ) { + # There is only one test, so use the serial output format. + return $self->SUPER::result( $result ); + } + + $self->_output_ruler( $self->parser->tests_run == 1 ); + } + elsif ( $result->is_bailout ) { $formatter->_failure_output( "Bailout called. Further testing stopped: " . $result->explanation . "\n" ); } +} - if ( $result->is_test ) { - $context->{tests}++; +=head3 C - my $test_print_modulus = 1; - my $ceiling = $context->{tests} / 5; - $test_print_modulus *= 2 while $test_print_modulus < $ceiling; +=cut - unless ( $context->{tests} % $test_print_modulus ) { - $self->_output_ruler; - } +sub clear_for_close { + my $self = shift; + my $formatter = $self->formatter; + return if $formatter->really_quiet; + my $context = $shared{$formatter}; + if ( @{ $context->{active} } == 1 ) { + $self->SUPER::clear_for_close; + } + else { + $self->_clear_ruler; } } @@ -146,27 +174,8 @@ sub close_test { my $formatter = $self->formatter; my $context = $shared{$formatter}; - unless ( $formatter->really_quiet ) { - $self->_clear_line; + $self->SUPER::close_test; - # 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; @@ -174,10 +183,14 @@ sub close_test { die "Can't find myself" unless @pos; splice @$active, $pos[0], 1; - $self->_need_refresh; - - unless (@$active) { - + if (@$active > 1) { + $self->_output_ruler( 1 ); + } + elsif (@$active == 1) { + # Print out "test/name.t ...." + $active->[0]->SUPER::header; + } + else { # $self->formatter->_output("\n"); delete $shared{$formatter}; } diff --git a/ext/Test/Harness/lib/TAP/Formatter/Console/Session.pm b/ext/Test/Harness/lib/TAP/Formatter/Console/Session.pm index 0c14f00..074407b 100644 --- a/ext/Test/Harness/lib/TAP/Formatter/Console/Session.pm +++ b/ext/Test/Harness/lib/TAP/Formatter/Console/Session.pm @@ -11,14 +11,14 @@ my @ACCESSOR; BEGIN { - @ACCESSOR = qw( name formatter parser ); + @ACCESSOR = qw( name formatter parser show_count ); for my $method (@ACCESSOR) { no strict 'refs'; *$method = sub { shift->{$method} }; } - my @CLOSURE_BINDING = qw( header result close_test ); + my @CLOSURE_BINDING = qw( header result clear_for_close close_test ); for my $method (@CLOSURE_BINDING) { no strict 'refs'; @@ -36,11 +36,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION @@ -71,6 +71,8 @@ The constructor returns a new C object. =item * C +=item * C + =back =cut @@ -86,6 +88,13 @@ sub _initialize { $self->{$name} = delete $arg_for{$name}; } + if ( !defined $self->show_count ) { + $self->{show_count} = 1; # defaults to true + } + if ( $self->show_count ) { # but may be a damned lie! + $self->{show_count} = $self->_should_show_count; + } + if ( my @props = sort keys %arg_for ) { $self->_croak("Unknown arguments to TAP::Harness::new (@props)"); } @@ -105,6 +114,11 @@ Called by the harness for each line of TAP it receives. Called to close a test session. +=head3 C + +Called by C to clear the line showing test progress, or the parallel +test ruler, prior to printing the final test result. + =cut sub _get_output_result { @@ -151,8 +165,8 @@ sub _closures { my $parser = $self->parser; my $formatter = $self->formatter; - my $show_count = $self->_should_show_count; my $pretty = $formatter->_format_name( $self->name ); + my $show_count = $self->show_count; my $really_quiet = $formatter->really_quiet; my $quiet = $formatter->quiet; @@ -202,10 +216,11 @@ sub _closures { 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 ) ) - { + # Print status roughly once per second. + # We will always get the first number as a side effect of + # $last_status_printed starting with the value 0, which $now + # will never be. (Unless someone sets their clock to 1970) + if ( $last_status_printed != $now ) { $formatter->$output("\r$pretty$number$plan"); $last_status_printed = $now; } @@ -226,7 +241,17 @@ sub _closures { } }, + clear_for_close => sub { + my $spaces = ' ' x + length( '.' . $pretty . $plan . $parser->tests_run ); + $formatter->$output("\r$spaces"); + }, + close_test => sub { + if ($show_count && !$really_quiet) { + $self->clear_for_close; + $formatter->$output("\r$pretty"); + } # Avoid circular references $self->parser(undef); @@ -234,12 +259,6 @@ sub _closures { 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"); } diff --git a/ext/Test/Harness/lib/TAP/Harness.pm b/ext/Test/Harness/lib/TAP/Harness.pm index 774152a..27961cc 100644 --- a/ext/Test/Harness/lib/TAP/Harness.pm +++ b/ext/Test/Harness/lib/TAP/Harness.pm @@ -8,10 +8,6 @@ use File::Path; use IO::Handle; use TAP::Base; -use TAP::Parser; -use TAP::Parser::Aggregator; -use TAP::Parser::Multiplexer; -use TAP::Parser::Scheduler; use vars qw($VERSION @ISA); @@ -23,11 +19,11 @@ TAP::Harness - Run test scripts with statistics =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; @@ -64,7 +60,7 @@ sub _error { BEGIN { @FORMATTER_ARGS = qw( - directives verbosity timer failures errors stdout color + directives verbosity timer failures errors stdout color show_count ); %VALIDATION_FOR = ( @@ -74,16 +70,20 @@ BEGIN { 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 }, - ignore_exit => sub { shift; shift }, - rules => sub { shift; shift }, + switches => sub { shift; shift }, + exec => sub { shift; shift }, + merge => sub { shift; shift }, + aggregator_class => sub { shift; shift }, + formatter_class => sub { shift; shift }, + multiplexer_class => sub { shift; shift }, + parser_class => sub { shift; shift }, + scheduler_class => sub { shift; shift }, + formatter => sub { shift; shift }, + jobs => sub { shift; shift }, + fork => sub { shift; shift }, + test_args => sub { shift; shift }, + ignore_exit => sub { shift; shift }, + rules => sub { shift; shift }, ); for my $method ( sort keys %VALIDATION_FOR ) { @@ -137,8 +137,8 @@ BEGIN { ) my $harness = TAP::Harness->new( \%args ); -The constructor returns a new C object. It accepts an optional -hashref whose allowed keys are: +The constructor returns a new C object. It accepts an +optional hashref whose allowed keys are: =over 4 @@ -151,26 +151,33 @@ Set the verbosity level: -1 quiet Suppress some test output (mostly failures while tests are running). -2 really quiet Suppress everything but the tests summary. + -3 silent Suppress everything. =item * C -Append run time for each test to output. Uses L if available. +Append run time for each test to output. Uses L if +available. =item * C Only show test failures (this is a no-op if C is selected). +=item * C + +Update the running test count during testing. + =item * C -Accepts a scalar value or array ref of scalar values indicating which paths to -allowed libraries should be included if Perl tests are executed. Naturally, -this only makes sense in the context of tests written in Perl. +Accepts a scalar value or array ref of scalar values indicating which +paths to allowed libraries should be included if Perl tests are +executed. Naturally, this only makes sense in the context of tests +written in Perl. =item * C -Accepts a scalar value or array ref of scalar values indicating which switches -should be included if Perl tests are executed. Naturally, this only makes -sense in the context of tests written in Perl. +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 @@ -183,37 +190,59 @@ Attempt to produce color output. =item * C -Typically, Perl tests are run through this. However, anything which spits out -TAP is fine. You can use this argument to specify the name of the program -(and optional switches) to run your tests with: +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'] -You can also pass a subroutine reference in order to determine and return the -proper program to run based on a given test script. The subroutine reference -should expect the TAP::Harness object itself as the first argument, and the -file name as the second argument. It should return an array reference -containing the command to be run and including the test file name. It can also -simply return C, in which case TAP::Harness will fall back on executing -the test script in Perl: - - exec => sub { - my ( $harness, $test_file ) = @_; - # Let Perl tests run. - return undef if $test_file =~ /[.]t$/; - return [ qw( /usr/bin/ruby -w ), $test_file ] if $test_file =~ /[.]rb$/; - } +You can also pass a subroutine reference in order to determine and +return the proper program to run based on a given test script. The +subroutine reference should expect the TAP::Harness object itself as the +first argument, and the file name as the second argument. It should +return an array reference containing the command to be run and including +the test file name. It can also simply return C, in which case +TAP::Harness will fall back on executing the test script in Perl: + + exec => sub { + my ( $harness, $test_file ) = @_; + + # Let Perl tests run. + return undef if $test_file =~ /[.]t$/; + return [ qw( /usr/bin/ruby -w ), $test_file ] + if $test_file =~ /[.]rb$/; + } =item * C If C is true the harness will create parsers that merge STDOUT and STDERR together for any processes they start. +=item * C + +The name of the class to use to aggregate test results. The default is +L. + =item * C The name of the class to use to format output. The default is L. +=item * C + +The name of the class to use to multiplex tests during parallel testing. +The default is L. + +=item * C + +The name of the class to use to parse TAP. The default is +L. + +=item * C + +The name of the class to use to schedule test execution. The default is +L. + =item * C If set C must be an object that is capable of formatting the @@ -221,22 +250,35 @@ TAP output. See L for an example. =item * C -If parse errors are found in the TAP output, a note of this will be made -in the summary report. To see all of the parse errors, set this argument to -true: +If parse errors are found in the TAP output, a note of this will be +made in the summary report. To see all of the parse errors, set this +argument to true: errors => 1 =item * C -If set to a true value, only test results with directives will be displayed. -This overrides other settings such as C or C. +If set to a true value, only test results with directives will be +displayed. This overrides other settings such as C or +C. =item * C If set to a true value instruct C to ignore exit and wait status from test scripts. +=item * C + +The maximum number of parallel tests to run at any time. Which tests +can be run in parallel is controlled by C. The default is to +run only one test at a time. + +=item * C + +If true the harness will attempt to fork and run the parser for each +test in a separate process. Currently this option requires +L to be installed. + =item * C A reference to a hash of rules that control which tests may be @@ -275,6 +317,14 @@ Any keys for which the value is C will be ignored. after_test ); + my %default_class = ( + aggregator_class => 'TAP::Parser::Aggregator', + formatter_class => 'TAP::Formatter::Console', + multiplexer_class => 'TAP::Parser::Multiplexer', + parser_class => 'TAP::Parser', + scheduler_class => 'TAP::Parser::Scheduler', + ); + sub _initialize { my ( $self, $arg_for ) = @_; $arg_for ||= {}; @@ -297,16 +347,11 @@ Any keys for which the value is C will be ignored. $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; + while ( my ( $attr, $class ) = each %default_class ) { + $self->$attr( $self->$attr() || $class ); + } - eval "require $class"; - $self->_croak("Can't load $class") if $@; + unless ( $self->formatter ) { # This is a little bodge to preserve legacy behaviour. It's # pretty horrible that we know which args are destined for @@ -318,7 +363,9 @@ Any keys for which the value is C will be ignored. } } - $self->formatter( $class->new( \%formatter_args ) ); + $self->formatter( + $self->_construct( $self->formatter_class, \%formatter_args ) + ); } if ( my @props = sort keys %arg_for ) { @@ -337,10 +384,10 @@ Any keys for which the value is C will be ignored. $harness->runtests(@tests); -Accepts and array of C<@tests> to be run. This should generally be the names -of test files, but this is not required. Each element in C<@tests> will be -passed to C as a C. See L for more -information. +Accepts and array of C<@tests> to be run. This should generally be the +names of test files, but this is not required. Each element in C<@tests> +will be passed to C as a C. See +L for more information. It is possible to provide aliases that will be displayed in place of the test name by supplying the test as a reference to an array containing @@ -367,7 +414,7 @@ Returns a L containing the test results. sub runtests { my ( $self, @tests ) = @_; - my $aggregate = TAP::Parser::Aggregator->new; + my $aggregate = $self->_construct( $self->aggregator_class ); $self->_make_callback( 'before_runtests', $aggregate ); $aggregate->start; @@ -442,7 +489,7 @@ sub _aggregate_parallel { my ( $self, $aggregate, $scheduler ) = @_; my $jobs = $self->jobs; - my $mux = TAP::Parser::Multiplexer->new; + my $mux = $self->_construct( $self->multiplexer_class ); RESULT: { @@ -521,17 +568,20 @@ may be run using different C settings. This is useful, for example, in the case where some tests should run in parallel but others are unsuitable for parallel execution. - my $formatter = TAP::Formatter::Console->new; + my $formatter = TAP::Formatter::Console->new; my $ser_harness = TAP::Harness->new( { formatter => $formatter } ); - my $par_harness = TAP::Harness->new( { formatter => $formatter, - jobs => 9 } ); + my $par_harness = TAP::Harness->new( + { formatter => $formatter, + jobs => 9 + } + ); my $aggregator = TAP::Parser::Aggregator->new; - + $aggregator->start(); $ser_harness->aggregate_tests( $aggregator, @ser_tests ); $par_harness->aggregate_tests( $aggregator, @par_tests ); $aggregator->stop(); - $formatter->summary( $aggregator ); + $formatter->summary($aggregator); Note that for simpler testing requirements it will often be possible to replace the above code with a single call to C. @@ -615,7 +665,8 @@ that was passed to C. sub make_scheduler { my ( $self, @tests ) = @_; - return TAP::Parser::Scheduler->new( + return $self->_construct( + $self->scheduler_class, tests => [ $self->_add_descriptions(@tests) ], rules => $self->rules ); @@ -623,9 +674,10 @@ sub make_scheduler { =head3 C -Returns the number of concurrent test runs the harness is handling. For the default -harness this value is always 1. A parallel harness such as L -will override this to return the number of jobs it is handling. +Gets or sets the number of concurrent test runs the harness is handling. +For the default harness this value is always 1. A parallel harness such +as L will override this to return the number of +jobs it is handling. =head3 C @@ -639,8 +691,9 @@ L to be installed. =head1 SUBCLASSING -C is designed to be (mostly) easy to subclass. If you don't -like how a particular feature functions, just override the desired methods. +C is designed to be (mostly) easy to subclass. If you +don't like how a particular feature functions, just override the +desired methods. =head2 Methods @@ -653,21 +706,22 @@ subclass C. $harness->summary( \%args ); -C prints the summary report after all tests are run. The argument is -a hashref with the following keys: +C prints the summary report after all tests are run. The +argument is a hashref with the following keys: =over 4 =item * C -This is created with C<< Benchmark->new >> and it the time the tests started. -You can print a useful summary time, if desired, with: +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' )); + $self->output( + timestr( timediff( Benchmark->new, $start_time ), 'nop' ) ); =item * C -This is an array reference of all test names. To get the L +This is an array reference of all test names. To get the L object for individual tests: my $aggregate = $args->{aggregate}; @@ -721,7 +775,6 @@ overridden in subclasses. my ( $parser, $session ) = $harness->make_parser; - =cut sub make_parser { @@ -729,7 +782,7 @@ sub make_parser { my $args = $self->_get_parser_args($job); $self->_make_callback( 'parser_args', $args, $job->as_array_ref ); - my $parser = TAP::Parser->new($args); + my $parser = $self->_construct( $self->parser_class, $args ); $self->_make_callback( 'made_parser', $parser, $job->as_array_ref ); my $session = $self->formatter->open_test( $job->description, $parser ); diff --git a/ext/Test/Harness/lib/TAP/Object.pm b/ext/Test/Harness/lib/TAP/Object.pm index 71a0a88..bbc7bfd 100644 --- a/ext/Test/Harness/lib/TAP/Object.pm +++ b/ext/Test/Harness/lib/TAP/Object.pm @@ -9,11 +9,11 @@ TAP::Object - Base class that provides common functionality to all C mod =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS @@ -93,5 +93,26 @@ sub _croak { return; } +=head3 C<_construct> + +Create a new instance of the specified class. + +=cut + +sub _construct { + my ( $self, $class, @args ) = @_; + + $self->_croak("Bad module name $class") + unless $class =~ /^ \w+ (?: :: \w+ ) *$/x; + + unless ( $class->can('new') ) { + local $@; + eval "require $class"; + $self->_croak("Can't load $class") if $@; + } + + return $class->new(@args); +} + 1; diff --git a/ext/Test/Harness/lib/TAP/Parser.pm b/ext/Test/Harness/lib/TAP/Parser.pm index 62a8b51..c02f2ac 100644 --- a/ext/Test/Harness/lib/TAP/Parser.pm +++ b/ext/Test/Harness/lib/TAP/Parser.pm @@ -22,11 +22,11 @@ TAP::Parser - Parse L output =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; @@ -1850,6 +1850,8 @@ Leif Eriksen Steve Purkis +Nicholas Clark + =head1 BUGS Please report any bugs or feature requests to diff --git a/ext/Test/Harness/lib/TAP/Parser/Aggregator.pm b/ext/Test/Harness/lib/TAP/Parser/Aggregator.pm index 5ed7fdb..d6fad64 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Aggregator.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Aggregator.pm @@ -14,11 +14,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Grammar.pm b/ext/Test/Harness/lib/TAP/Parser/Grammar.pm index d56d0cb..a644b07 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Grammar.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Grammar.pm @@ -15,11 +15,11 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS @@ -148,8 +148,8 @@ my %language_for; ( $desc, $dir, $explanation ) = ( $1, $2, $3 ); } return $self->_make_test_token( - $line, $ok, $num, $desc, - $dir, $explanation + $line, $ok, $num, $desc, + $dir, $explanation ); }, }, @@ -401,16 +401,15 @@ sub _make_plan_token { sub _make_test_token { my ( $self, $line, $ok, $num, $desc, $dir, $explanation ) = @_; - my %test = ( + return { ok => $ok, test_num => $num, description => _trim($desc), - directive => uc( defined $dir ? $dir : '' ), + directive => ( defined $dir ? uc $dir : '' ), explanation => _trim($explanation), raw => $line, type => 'test', - ); - return \%test; + }; } sub _make_unknown_token { diff --git a/ext/Test/Harness/lib/TAP/Parser/Iterator.pm b/ext/Test/Harness/lib/TAP/Parser/Iterator.pm index 0d471d9..d33a963 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Iterator.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Iterator.pm @@ -13,11 +13,11 @@ TAP::Parser::Iterator - Internal base class for TAP::Parser Iterators =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Iterator/Array.pm b/ext/Test/Harness/lib/TAP/Parser/Iterator/Array.pm index 3eef09a..4495bb8 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Iterator/Array.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Iterator/Array.pm @@ -13,11 +13,11 @@ TAP::Parser::Iterator::Array - Internal TAP::Parser array Iterator =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Iterator/Process.pm b/ext/Test/Harness/lib/TAP/Parser/Iterator/Process.pm index bcc3420..cc9786c 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Iterator/Process.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Iterator/Process.pm @@ -17,11 +17,11 @@ TAP::Parser::Iterator::Process - Internal TAP::Parser Iterator =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Iterator/Stream.pm b/ext/Test/Harness/lib/TAP/Parser/Iterator/Stream.pm index 3f2febf..e71dfc4 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Iterator/Stream.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -13,11 +13,11 @@ TAP::Parser::Iterator::Stream - Internal TAP::Parser Iterator =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/IteratorFactory.pm b/ext/Test/Harness/lib/TAP/Parser/IteratorFactory.pm index b2c1cdd..7aa4e4d 100644 --- a/ext/Test/Harness/lib/TAP/Parser/IteratorFactory.pm +++ b/ext/Test/Harness/lib/TAP/Parser/IteratorFactory.pm @@ -16,11 +16,11 @@ TAP::Parser::IteratorFactory - Internal TAP::Parser Iterator =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Multiplexer.pm b/ext/Test/Harness/lib/TAP/Parser/Multiplexer.pm index f572756..2efeb30 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Multiplexer.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Multiplexer.pm @@ -18,11 +18,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Result.pm b/ext/Test/Harness/lib/TAP/Parser/Result.pm index eb27a19..486c6ff 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result.pm @@ -26,11 +26,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS @@ -68,8 +68,10 @@ sub _initialize { my ( $self, $token ) = @_; if ($token) { - # make a shallow copy of the token: - $self->{$_} = $token->{$_} for ( keys %$token ); + # assign to a hash slice to make a shallow copy of the token. + # I guess we could assign to the hash as (by default) there are not + # contents, but that seems less helpful if someone wants to subclass us + @{$self}{keys %$token} = values %$token; } return $self; } @@ -293,6 +295,6 @@ L, L, L, L, -L, +L, =cut diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Bailout.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Bailout.pm index b20d031..a4c9bbd 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Bailout.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Bailout.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Comment.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Comment.pm index aaa78da..04a2ce0 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Comment.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Comment.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Plan.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Plan.pm index c851f22..3225586 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Plan.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Plan.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Pragma.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Pragma.pm index b89c713..b0ea82a 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Pragma.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Pragma.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Test.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Test.pm index b36a7ce..4c12f61 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Test.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Test.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Unknown.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Unknown.pm index 47c888e..0316fb0 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Unknown.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Unknown.pm @@ -14,11 +14,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/Version.pm b/ext/Test/Harness/lib/TAP/Parser/Result/Version.pm index 62bac2e..3688f2b 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/Version.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/Version.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Result/YAML.pm b/ext/Test/Harness/lib/TAP/Parser/Result/YAML.pm index f1b99ef..d1e9cf6 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Result/YAML.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Result/YAML.pm @@ -12,11 +12,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/ResultFactory.pm b/ext/Test/Harness/lib/TAP/Parser/ResultFactory.pm index bf4797f..5d33935 100644 --- a/ext/Test/Harness/lib/TAP/Parser/ResultFactory.pm +++ b/ext/Test/Harness/lib/TAP/Parser/ResultFactory.pm @@ -30,11 +30,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head2 DESCRIPTION diff --git a/ext/Test/Harness/lib/TAP/Parser/Scheduler.pm b/ext/Test/Harness/lib/TAP/Parser/Scheduler.pm index e0dea76..c90432e 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Scheduler.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Scheduler.pm @@ -12,11 +12,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS @@ -110,18 +110,70 @@ sub _rule_clause { ); } +sub _glob_to_regexp { + my ( $self, $glob ) = @_; + my $nesting; + my $pattern; + + while (1) { + if ( $glob =~ /\G\*\*/gc ) { + + # ** is any number of characters, including /, within a pathname + $pattern .= '.*?'; + } + elsif ( $glob =~ /\G\*/gc ) { + + # * is zero or more characters within a filename/directory name + $pattern .= '[^/]*'; + } + elsif ( $glob =~ /\G\?/gc ) { + + # ? is exactly one character within a filename/directory name + $pattern .= '[^/]'; + } + elsif ( $glob =~ /\G\{/gc ) { + + # {foo,bar,baz} is any of foo, bar or baz. + $pattern .= '(?:'; + ++$nesting; + } + elsif ( $nesting and $glob =~ /\G,/gc ) { + + # , is only special inside {} + $pattern .= '|'; + } + elsif ( $nesting and $glob =~ /\G\}/gc ) { + + # } that matches { is special. But unbalanced } are not. + $pattern .= ')'; + --$nesting; + } + elsif ( $glob =~ /\G(\\.)/gc ) { + + # A quoted literal + $pattern .= $1; + } + elsif ( $glob =~ /\G([\},])/gc ) { + + # Sometimes meta characters + $pattern .= '\\' . $1; + } + else { + + # Eat everything that is not a meta character. + $glob =~ /\G([^{?*\\\},]*)/gc; + $pattern .= quotemeta $1; + } + return $pattern if pos $glob == length $glob; + } +} + sub _expand { my ( $self, $name, $tests ) = @_; - $name =~ s{(\?|\*\*?|.)}{ - $1 eq '?' ? '[^/]' - : $1 eq '*' ? '[^/]*' - : $1 eq '**' ? '.*?' - : quotemeta($1); - }gex; - - my $pattern = qr{^$name$}; - my @match = (); + my $pattern = $self->_glob_to_regexp($name); + $pattern = qr/^ $pattern $/x; + my @match = (); for ( my $ti = 0; $ti < @$tests; $ti++ ) { if ( $tests->[$ti]->filename =~ $pattern ) { @@ -141,14 +193,16 @@ Get a list of all remaining tests. sub get_all { my $self = shift; - $self->_gather( $self->{schedule} ); + my @all = $self->_gather( $self->{schedule} ); + $self->{count} = @all; + @all; } sub _gather { my ( $self, $rule ) = @_; return unless defined $rule; return $rule unless 'ARRAY' eq ref $rule; - return map { $self->_gather($_) } grep {defined} map {@$_} @$rule; + return map { defined () ? $self->_gather($_) : () } map {@$_} @$rule; } =head3 C @@ -161,20 +215,25 @@ jobs but none are available to run right now. sub get_job { my $self = shift; + $self->{count} ||= $self->get_all; my @jobs = $self->_find_next_job( $self->{schedule} ); - return $jobs[0] if @jobs; + if (@jobs) { + --$self->{count}; + return $jobs[0]; + } - # TODO: This isn't very efficient... return TAP::Parser::Scheduler::Spinner->new - if $self->get_all; + if $self->{count}; return; } sub _not_empty { my $ar = shift; - return 1 unless defined $ar && 'ARRAY' eq ref $ar; - return 1 if grep { _not_empty($_) } @$ar; + return 1 unless 'ARRAY' eq ref $ar; + foreach (@$ar) { + return 1 if _not_empty($_); + } return; } @@ -184,19 +243,27 @@ sub _find_next_job { my ( $self, $rule ) = @_; my @queue = (); - for my $seq (@$rule) { - + my $index = 0; + while ($index < @$rule) { + my $seq = $rule->[$index]; # Prune any exhausted items. shift @$seq while @$seq && _is_empty( $seq->[0] ); - if ( @$seq && defined $seq->[0] ) { - if ( 'ARRAY' eq ref $seq->[0] ) { - push @queue, $seq; - } - else { - my $job = splice @$seq, 0, 1, undef; - $job->on_finish( sub { shift @$seq } ); - return $job; + if ( @$seq ) { + if ( defined $seq->[0] ) { + if ( 'ARRAY' eq ref $seq->[0] ) { + push @queue, $seq; + } + else { + my $job = splice @$seq, 0, 1, undef; + $job->on_finish( sub { shift @$seq } ); + return $job; + } } + ++$index; + } + else { + # Remove the empty sub-array from the array + splice @$rule, $index, 1; } } diff --git a/ext/Test/Harness/lib/TAP/Parser/Scheduler/Job.pm b/ext/Test/Harness/lib/TAP/Parser/Scheduler/Job.pm index 2dc05e0..fe55faf 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Scheduler/Job.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS @@ -43,7 +43,7 @@ sub new { return bless { filename => $name, description => $desc, - context => \@ctx, + @ctx ? ( context => \@ctx ) : (), }, $class; } @@ -81,7 +81,7 @@ sub finish { sub filename { shift->{filename} } sub description { shift->{description} } -sub context { @{ shift->{context} } } +sub context { @{ shift->{context} || [] } } =head3 C @@ -91,7 +91,7 @@ For backwards compatibility in callbacks. sub as_array_ref { my $self = shift; - return [ $self->filename, $self->description, $self->context ]; + return [ $self->filename, $self->description, $self->{context} ||= [] ]; } =head3 C diff --git a/ext/Test/Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/ext/Test/Harness/lib/TAP/Parser/Scheduler/Spinner.pm index 6a0fa60..25f1b4a 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Source.pm b/ext/Test/Harness/lib/TAP/Parser/Source.pm index 9fc97a9..3b10482 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Source.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Source.pm @@ -17,11 +17,11 @@ TAP::Parser::Source - Stream output from some source =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/Source/Perl.pm b/ext/Test/Harness/lib/TAP/Parser/Source/Perl.pm index fd60a76..444b429 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Source/Perl.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Source/Perl.pm @@ -8,6 +8,8 @@ use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant IS_VMS => ( $^O eq 'VMS' ); use TAP::Parser::Source; +use TAP::Parser::Utils qw( split_shell ); + @ISA = 'TAP::Parser::Source'; =head1 NAME @@ -16,11 +18,11 @@ TAP::Parser::Source::Perl - Stream Perl output =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS @@ -145,14 +147,14 @@ sub get_stream { # 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 ) { + if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { push @switches, $self->_libs2switches( split $path_pat, $ENV{PERL5LIB} || $ENV{PERLLIB} || '' ); - push @switches, $ENV{PERL5OPT} || (); + push @switches, split_shell( $ENV{PERL5OPT} ); } my @command = $self->_get_command_for_switches(@switches) diff --git a/ext/Test/Harness/lib/TAP/Parser/Utils.pm b/ext/Test/Harness/lib/TAP/Parser/Utils.pm index 837c63e..85174c0 100644 --- a/ext/Test/Harness/lib/TAP/Parser/Utils.pm +++ b/ext/Test/Harness/lib/TAP/Parser/Utils.pm @@ -13,11 +13,11 @@ TAP::Parser::Utils - Internal TAP::Parser utilities =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/YAMLish/Reader.pm b/ext/Test/Harness/lib/TAP/Parser/YAMLish/Reader.pm index fca56de..cc39350 100644 --- a/ext/Test/Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ b/ext/Test/Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.13'; +$VERSION = '3.14'; # TODO: # Handle blessed object syntax @@ -270,7 +270,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.13 +Version 3.14 =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/TAP/Parser/YAMLish/Writer.pm b/ext/Test/Harness/lib/TAP/Parser/YAMLish/Writer.pm index 5889ac1..98301a3 100644 --- a/ext/Test/Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ b/ext/Test/Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -6,7 +6,7 @@ use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; -$VERSION = '3.13'; +$VERSION = '3.14'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -127,7 +127,7 @@ sub _write_obj { } } else { - die "Don't know how to enocde $ref"; + die "Don't know how to encode $ref"; } } else { @@ -147,7 +147,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.13 +Version 3.14 =head1 SYNOPSIS diff --git a/ext/Test/Harness/lib/Test/Harness.pm b/ext/Test/Harness/lib/Test/Harness.pm index 4f0164e..24566ba 100644 --- a/ext/Test/Harness/lib/Test/Harness.pm +++ b/ext/Test/Harness/lib/Test/Harness.pm @@ -44,11 +44,11 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 3.13 +Version 3.14 =cut -$VERSION = '3.13'; +$VERSION = '3.14'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; @@ -290,7 +290,7 @@ sub _filtered_inc { elsif (IS_WIN32) { # Lose any trailing backslashes in the Win32 paths - s/[\\\/+]$// foreach @inc; + s/[\\\/]+$// foreach @inc; } my @default_inc = _default_inc(); diff --git a/ext/Test/Harness/t/000-load.t b/ext/Test/Harness/t/000-load.t index c6d6a92..58d41bf 100644 --- a/ext/Test/Harness/t/000-load.t +++ b/ext/Test/Harness/t/000-load.t @@ -3,7 +3,7 @@ use strict; use lib 't/lib'; -use Test::More tests => 74; +use Test::More tests => 78; BEGIN { @@ -12,6 +12,8 @@ BEGIN { TAP::Parser App::Prove App::Prove::State + App::Prove::State::Result + App::Prove::State::Result::Test TAP::Base TAP::Formatter::Color TAP::Formatter::Console::ParallelSession diff --git a/ext/Test/Harness/t/compat/failure.t b/ext/Test/Harness/t/compat/failure.t index b164f9b..759b664 100644 --- a/ext/Test/Harness/t/compat/failure.t +++ b/ext/Test/Harness/t/compat/failure.t @@ -20,12 +20,15 @@ use Test::Harness; } my $sample_tests; - if ($ENV{PERL_CORE}) { - my $updir = File::Spec->updir; - $sample_tests = File::Spec->catdir( $updir, 'ext', 'Test', 'Harness', 't', 'sample-tests' ); - } else { - my $curdir = File::Spec->curdir; - $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); + if ( $ENV{PERL_CORE} ) { + my $updir = File::Spec->updir; + $sample_tests + = File::Spec->catdir( $updir, 'ext', 'Test', 'Harness', 't', + 'sample-tests' ); + } + else { + my $curdir = File::Spec->curdir; + $sample_tests = File::Spec->catdir( $curdir, 't', 'sample-tests' ); } { diff --git a/ext/Test/Harness/t/compat/test-harness-compat.t b/ext/Test/Harness/t/compat/test-harness-compat.t index 480d6d8..00fab13 100644 --- a/ext/Test/Harness/t/compat/test-harness-compat.t +++ b/ext/Test/Harness/t/compat/test-harness-compat.t @@ -1,33 +1,35 @@ #!/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; + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + unshift @INC, 't/lib'; } } use strict; -use lib 't/lib'; +# 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}; +my $TEST_DIR + = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/sample-tests' : 't/sample-tests'; + { # 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 = { @@ -58,110 +60,110 @@ local $ENV{HARNESS_PERL_SWITCHES}; ) ) => { 'failed' => { - 't/sample-tests/die' => { + "$TEST_DIR/die" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', - 'name' => 't/sample-tests/die', + 'name' => "$TEST_DIR/die", 'wstat' => '256' }, - 't/sample-tests/die_head_end' => { + "$TEST_DIR/die_head_end" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', - 'name' => 't/sample-tests/die_head_end', + 'name' => "$TEST_DIR/die_head_end", 'wstat' => '256' }, - 't/sample-tests/die_last_minute' => { + "$TEST_DIR/die_last_minute" => { 'canon' => '??', 'estat' => 1, 'failed' => 0, 'max' => 4, - 'name' => 't/sample-tests/die_last_minute', + 'name' => "$TEST_DIR/die_last_minute", 'wstat' => '256' }, - 't/sample-tests/duplicates' => { + "$TEST_DIR/duplicates" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => 10, - 'name' => 't/sample-tests/duplicates', + 'name' => "$TEST_DIR/duplicates", 'wstat' => '' }, - 't/sample-tests/head_fail' => { + "$TEST_DIR/head_fail" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 4, - 'name' => 't/sample-tests/head_fail', + 'name' => "$TEST_DIR/head_fail", 'wstat' => '' }, - 't/sample-tests/inc_taint' => { + "$TEST_DIR/inc_taint" => { 'canon' => 1, 'estat' => 1, 'failed' => 1, 'max' => 1, - 'name' => 't/sample-tests/inc_taint', + 'name' => "$TEST_DIR/inc_taint", 'wstat' => '256' }, - 't/sample-tests/no_nums' => { + "$TEST_DIR/no_nums" => { 'canon' => 3, 'estat' => '', 'failed' => 1, 'max' => 5, - 'name' => 't/sample-tests/no_nums', + 'name' => "$TEST_DIR/no_nums", 'wstat' => '' }, - 't/sample-tests/no_output' => { + "$TEST_DIR/no_output" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => '??', - 'name' => 't/sample-tests/no_output', + 'name' => "$TEST_DIR/no_output", 'wstat' => '' }, - 't/sample-tests/simple_fail' => { + "$TEST_DIR/simple_fail" => { 'canon' => '2 5', 'estat' => '', 'failed' => 2, 'max' => 5, - 'name' => 't/sample-tests/simple_fail', + 'name' => "$TEST_DIR/simple_fail", 'wstat' => '' }, - 't/sample-tests/todo_misparse' => { + "$TEST_DIR/todo_misparse" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 1, - 'name' => 't/sample-tests/todo_misparse', + 'name' => "$TEST_DIR/todo_misparse", 'wstat' => '' }, - 't/sample-tests/too_many' => { + "$TEST_DIR/too_many" => { 'canon' => '4-7', 'estat' => 4, 'failed' => 4, 'max' => 3, - 'name' => 't/sample-tests/too_many', + 'name' => "$TEST_DIR/too_many", 'wstat' => '1024' }, - 't/sample-tests/vms_nit' => { + "$TEST_DIR/vms_nit" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 2, - 'name' => 't/sample-tests/vms_nit', + 'name' => "$TEST_DIR/vms_nit", 'wstat' => '' } }, 'todo' => { - 't/sample-tests/todo_inline' => { + "$TEST_DIR/todo_inline" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 2, - 'name' => 't/sample-tests/todo_inline', + 'name' => "$TEST_DIR/todo_inline", 'wstat' => '' } }, @@ -180,12 +182,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'die' => { 'failed' => { - 't/sample-tests/die' => { + "$TEST_DIR/die" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', - 'name' => 't/sample-tests/die', + 'name' => "$TEST_DIR/die", 'wstat' => '256' } }, @@ -205,12 +207,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'die_head_end' => { 'failed' => { - 't/sample-tests/die_head_end' => { + "$TEST_DIR/die_head_end" => { 'canon' => '??', 'estat' => 1, 'failed' => '??', 'max' => '??', - 'name' => 't/sample-tests/die_head_end', + 'name' => "$TEST_DIR/die_head_end", 'wstat' => '256' } }, @@ -230,12 +232,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'die_last_minute' => { 'failed' => { - 't/sample-tests/die_last_minute' => { + "$TEST_DIR/die_last_minute" => { 'canon' => '??', 'estat' => 1, 'failed' => 0, 'max' => 4, - 'name' => 't/sample-tests/die_last_minute', + 'name' => "$TEST_DIR/die_last_minute", 'wstat' => '256' } }, @@ -255,12 +257,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'duplicates' => { 'failed' => { - 't/sample-tests/duplicates' => { + "$TEST_DIR/duplicates" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => 10, - 'name' => 't/sample-tests/duplicates', + 'name' => "$TEST_DIR/duplicates", 'wstat' => '' } }, @@ -296,12 +298,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'head_fail' => { 'failed' => { - 't/sample-tests/head_fail' => { + "$TEST_DIR/head_fail" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 4, - 'name' => 't/sample-tests/head_fail', + 'name' => "$TEST_DIR/head_fail", 'wstat' => '' } }, @@ -321,12 +323,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'inc_taint' => { 'failed' => { - 't/sample-tests/inc_taint' => { + "$TEST_DIR/inc_taint" => { 'canon' => 1, 'estat' => 1, 'failed' => 1, 'max' => 1, - 'name' => 't/sample-tests/inc_taint', + 'name' => "$TEST_DIR/inc_taint", 'wstat' => '256' } }, @@ -378,12 +380,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'no_nums' => { 'failed' => { - 't/sample-tests/no_nums' => { + "$TEST_DIR/no_nums" => { 'canon' => 3, 'estat' => '', 'failed' => 1, 'max' => 5, - 'name' => 't/sample-tests/no_nums', + 'name' => "$TEST_DIR/no_nums", 'wstat' => '' } }, @@ -403,12 +405,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'no_output' => { 'failed' => { - 't/sample-tests/no_output' => { + "$TEST_DIR/no_output" => { 'canon' => '??', 'estat' => '', 'failed' => '??', 'max' => '??', - 'name' => 't/sample-tests/no_output', + 'name' => "$TEST_DIR/no_output", 'wstat' => '' } }, @@ -492,12 +494,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'simple_fail' => { 'failed' => { - 't/sample-tests/simple_fail' => { + "$TEST_DIR/simple_fail" => { 'canon' => '2 5', 'estat' => '', 'failed' => 2, 'max' => 5, - 'name' => 't/sample-tests/simple_fail', + 'name' => "$TEST_DIR/simple_fail", 'wstat' => '' } }, @@ -600,12 +602,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; ( $ENV{PERL5OPT} || '' ) =~ m{(?:^|\s)-[dM]}; }, 'failed' => { - 't/sample-tests/switches' => { + "$TEST_DIR/switches" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 1, - 'name' => 't/sample-tests/switches', + 'name' => "$TEST_DIR/switches", 'wstat' => '' } }, @@ -659,12 +661,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; 'todo_inline' => { 'failed' => {}, 'todo' => { - 't/sample-tests/todo_inline' => { + "$TEST_DIR/todo_inline" => { 'canon' => 2, 'estat' => '', 'failed' => 1, 'max' => 2, - 'name' => 't/sample-tests/todo_inline', + 'name' => "$TEST_DIR/todo_inline", 'wstat' => '' } }, @@ -683,12 +685,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'todo_misparse' => { 'failed' => { - 't/sample-tests/todo_misparse' => { + "$TEST_DIR/todo_misparse" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 1, - 'name' => 't/sample-tests/todo_misparse', + 'name' => "$TEST_DIR/todo_misparse", 'wstat' => '' } }, @@ -708,12 +710,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'too_many' => { 'failed' => { - 't/sample-tests/too_many' => { + "$TEST_DIR/too_many" => { 'canon' => '4-7', 'estat' => 4, 'failed' => 4, 'max' => 3, - 'name' => 't/sample-tests/too_many', + 'name' => "$TEST_DIR/too_many", 'wstat' => '1024' } }, @@ -733,12 +735,12 @@ local $ENV{HARNESS_PERL_SWITCHES}; }, 'vms_nit' => { 'failed' => { - 't/sample-tests/vms_nit' => { + "$TEST_DIR/vms_nit" => { 'canon' => 1, 'estat' => '', 'failed' => 1, 'max' => 2, - 'name' => 't/sample-tests/vms_nit', + 'name' => "$TEST_DIR/vms_nit", 'wstat' => '' } }, @@ -785,13 +787,13 @@ local $ENV{HARNESS_PERL_SWITCHES}; return $hash unless $^O eq 'VMS'; while ( my ( $file, $want ) = each %$hash ) { - for ( qw( estat wstat ) ) { + for (qw( estat wstat )) { if ( exists $want->{$_} ) { $want->{$_} = $want->{$_} ? 1 : 0; } } } - return $hash + return $hash; } { diff --git a/ext/Test/Harness/t/glob-to-regexp.t b/ext/Test/Harness/t/glob-to-regexp.t new file mode 100644 index 0000000..493daab --- /dev/null +++ b/ext/Test/Harness/t/glob-to-regexp.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More; + +require TAP::Parser::Scheduler; + +my @tests; +while () { + my ( $glob, $pattern, $name ) = /^(\S+)\t+(\S+)(?:\t+(.*))?$/; + die "'$_'" unless $pattern; + push @tests, [ $glob, $pattern, $name ]; +} + +plan tests => scalar @tests; + +foreach (@tests) { + my ( $glob, $pattern, $name ) = @$_; + is( TAP::Parser::Scheduler->_glob_to_regexp($glob), $pattern, + defined $name ? "$glob -- $name" : $glob + ); +} +__DATA__ +Pie Pie +*.t [^/]*\.t +**.t .*?\.t +A?B A[^/]B +*/*.t [^/]*\/[^/]*\.t +A,B A\,B , outside {} not special +{A,B} (?:A|B) +A{B}C A(?:B)C +A{B,C}D A(?:B|C)D +A{B,C,D}E{F,G,H}I,J A(?:B|C|D)E(?:F|G|H)I\,J +{Perl,Rules} (?:Perl|Rules) +A}B A\}B Bare } corner case +A{B,C}D}E A(?:B|C)D\}E +},A{B,C}D},E \}\,A(?:B|C)D\}\,E +{A{1,2},D{3,4}} (?:A(?:1|2)|D(?:3|4)) +{A,{B,C},D} (?:A|(?:B|C)|D) +A{B,C\}D,E\,F}G A(?:B|C\}D|E\,F)G +A\\B A\\B +A(B)C A\(B\)C +1{A(B)C,D|E}2 1(?:A\(B\)C|D\|E)2 diff --git a/ext/Test/Harness/t/harness-subclass.t b/ext/Test/Harness/t/harness-subclass.t new file mode 100644 index 0000000..0039b4d --- /dev/null +++ b/ext/Test/Harness/t/harness-subclass.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl -w + +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', '../ext/Test/Harness/t/lib' ); + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use TAP::Harness; +use Test::More tests => 13; + +my %class_map = ( + aggregator_class => 'My::TAP::Parser::Aggregator', + formatter_class => 'My::TAP::Formatter::Console', + multiplexer_class => 'My::TAP::Parser::Multiplexer', + parser_class => 'My::TAP::Parser', + scheduler_class => 'My::TAP::Parser::Scheduler', +); + +my %loaded = (); + +# Synthesize our subclasses +for my $class ( values %class_map ) { + ( my $base_class = $class ) =~ s/^My:://; + use_ok($base_class); + + no strict 'refs'; + @{"${class}::ISA"} = ($base_class); + *{"${class}::new"} = sub { + my $pkg = shift; + $loaded{$pkg} = 1; + + # Can't use SUPER outside a package + return $base_class->can('new')->( $pkg, @_ ); + }; +} + +{ + ok my $harness = TAP::Harness->new( { %class_map, verbosity => -9 } ), + 'created harness'; + isa_ok $harness, 'TAP::Harness'; + + # Test dynamic loading + ok !$INC{'NOP.pm'}, 'NOP not loaded'; + ok my $nop = $harness->_construct('NOP'), 'loaded and created'; + isa_ok $nop, 'NOP'; + ok $INC{'NOP.pm'}, 'NOP loaded'; + + my $aggregate = $harness->runtests( + File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir, 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests', + 'simple' + ) + ); + + isa_ok $aggregate, 'My::TAP::Parser::Aggregator'; + + is_deeply \%loaded, + { 'My::TAP::Parser::Aggregator' => 1, + 'My::TAP::Formatter::Console' => 1, + 'My::TAP::Parser' => 1, + 'My::TAP::Parser::Scheduler' => 1, + }, + 'loaded our classes'; +} diff --git a/ext/Test/Harness/t/harness.t b/ext/Test/Harness/t/harness.t index 32b9162..f80be21 100644 --- a/ext/Test/Harness/t/harness.t +++ b/ext/Test/Harness/t/harness.t @@ -19,8 +19,10 @@ use TAP::Harness; my $HARNESS = 'TAP::Harness'; -my $source_tests = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/source_tests' : 't/source_tests'; -my $sample_tests = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/sample-tests' : 't/sample-tests'; +my $source_tests + = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/source_tests' : 't/source_tests'; +my $sample_tests + = $ENV{PERL_CORE} ? '../ext/Test/Harness/t/sample-tests' : 't/sample-tests'; plan tests => 113; @@ -523,7 +525,9 @@ SKIP: { eval { _runtests( $harness, - $ENV{PERL_CORE} ? '../ext/Test/Harness/t/data/catme.1' : 't/data/catme.1' + $ENV{PERL_CORE} + ? '../ext/Test/Harness/t/data/catme.1' + : 't/data/catme.1' ); }; @@ -810,7 +814,13 @@ sub _runtests { # coverage tests for the basically untested T::H::_open_spool - my @spool = ( ( $ENV{PERL_CORE} ? (File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), ( 't', 'spool' ) ); + my @spool = ( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + ( 't', 'spool' ) + ); $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); # now given that we're going to be writing stuff to the file system, make sure we have @@ -849,7 +859,8 @@ sub _runtests { { name => 'all the same', input => [ 'foo.t', 'bar.t', 'fletz.t' ], output => [ - [ 'foo.t', 'foo' ], [ 'bar.t', 'bar' ], [ 'fletz.t', 'fletz' ] + [ 'foo.t', 'foo' ], [ 'bar.t', 'bar' ], + [ 'fletz.t', 'fletz' ] ], }, { name => 'all the same, already cooked', diff --git a/ext/Test/Harness/t/iterators.t b/ext/Test/Harness/t/iterators.t index e4df510..4771a58 100644 --- a/ext/Test/Harness/t/iterators.t +++ b/ext/Test/Harness/t/iterators.t @@ -42,8 +42,13 @@ my @schedule = ( command => [ $^X, File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'out_err_mix' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests', + 'out_err_mix' ) ], merge => 1, diff --git a/ext/Test/Harness/t/lib/NOP.pm b/ext/Test/Harness/t/lib/NOP.pm new file mode 100644 index 0000000..6de1dbf --- /dev/null +++ b/ext/Test/Harness/t/lib/NOP.pm @@ -0,0 +1,7 @@ +package NOP; + +# Do nothing much + +sub new { bless {}, shift } + +1; diff --git a/ext/Test/Harness/t/multiplexer.t b/ext/Test/Harness/t/multiplexer.t index eccbb0e..dc89cd9 100644 --- a/ext/Test/Harness/t/multiplexer.t +++ b/ext/Test/Harness/t/multiplexer.t @@ -56,8 +56,15 @@ my @schedule = ( return [ TAP::Parser->new( { source => File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'simple' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', + 'Harness' + ) + : () + ), + 't', + 'sample-tests', + 'simple' ), } ), @@ -76,8 +83,15 @@ my @schedule = ( return map { [ TAP::Parser->new( { source => File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'simple' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', + 'Harness' + ) + : () + ), + 't', + 'sample-tests', + 'simple' ), } ), @@ -116,8 +130,15 @@ my @schedule = ( ( map { [ TAP::Parser->new( { source => File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'simple' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', + 'Test', 'Harness' + ) + : () + ), + 't', + 'sample-tests', + 'simple' ), } ), diff --git a/ext/Test/Harness/t/nofork.t b/ext/Test/Harness/t/nofork.t index 72a2adb..9aa42a4 100755 --- a/ext/Test/Harness/t/nofork.t +++ b/ext/Test/Harness/t/nofork.t @@ -57,8 +57,8 @@ my $mod = 'TAP::Parser::Iterator::Process'; stdout => $capture, } ); - $harness->runtests( - ( $ENV{PERL_CORE} ? '../ext/Test/Harness/' : '' ) . 't/sample-tests/simple' ); + $harness->runtests( ( $ENV{PERL_CORE} ? '../ext/Test/Harness/' : '' ) + . 't/sample-tests/simple' ); my @output = tied($$capture)->dump; is pop @output, "Result: PASS\n", 'status OK'; pop @output; # get rid of summary line diff --git a/ext/Test/Harness/t/parse.t b/ext/Test/Harness/t/parse.t index b52f2c5..df80cd1 100755 --- a/ext/Test/Harness/t/parse.t +++ b/ext/Test/Harness/t/parse.t @@ -605,8 +605,13 @@ END_TAP my $parser = TAP::Parser->new( { source => File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'simple' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests', + 'simple' ), } ); diff --git a/ext/Test/Harness/t/process.t b/ext/Test/Harness/t/process.t index abebf69..a233906 100644 --- a/ext/Test/Harness/t/process.t +++ b/ext/Test/Harness/t/process.t @@ -28,8 +28,13 @@ my @expect = ( ); my $source = File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'delayed' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests', + 'delayed' ); for my $chunk_size ( 1, 4, 65536 ) { diff --git a/ext/Test/Harness/t/prove.t b/ext/Test/Harness/t/prove.t index c808870..06c37f6 100644 --- a/ext/Test/Harness/t/prove.t +++ b/ext/Test/Harness/t/prove.t @@ -164,11 +164,11 @@ BEGIN { # START PLAN expect => {}, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', - 'one', - 'two', - 'three' + 'one', 'two', 'three' ] ], }, @@ -201,7 +201,7 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, show_count => 1 }, 'TAP::Harness', 'one', 'two', 'three' @@ -219,7 +219,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -237,8 +238,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { color => 1, - verbosity => 0 + { color => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -257,7 +259,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { directives => 1, - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -274,8 +277,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { exec => [1], - verbosity => 0 + { exec => [1], + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -292,8 +296,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { failures => 1, - verbosity => 0 + { failures => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -312,7 +317,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { formatter_class => 'TAP::Harness', - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -331,7 +337,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( [qw( four five six )] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -349,7 +356,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -366,8 +374,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { merge => 1, - verbosity => 0 + { merge => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -384,8 +393,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { errors => 1, - verbosity => 0 + { errors => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -402,7 +412,8 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => -1 + { verbosity => -1, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -419,7 +430,8 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => -2 + { verbosity => -2, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -436,7 +448,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', 'one', 'two', 'three' ] @@ -452,7 +466,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', 'three', 'two', 'one' ] @@ -469,7 +485,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', 'xxxone', 'xxxtwo', 'xxxthree' @@ -486,8 +504,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { switches => ['-T'], - verbosity => 0 + { switches => ['-T'], + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -504,8 +523,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { switches => ['-t'], - verbosity => 0 + { switches => ['-t'], + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -522,7 +542,8 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 1 + { verbosity => 1, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -539,8 +560,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { switches => ['-W'], - verbosity => 0 + { switches => ['-W'], + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -557,8 +579,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { switches => ['-w'], - verbosity => 0 + { switches => ['-w'], + verbosity => 0, + show_count => 1, }, 'TAP::Harness', 'one', 'two', 'three' @@ -577,7 +600,8 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 1 + { verbosity => 1, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -595,7 +619,8 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { verbosity => 1 + { verbosity => 1, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -611,8 +636,9 @@ BEGIN { # START PLAN expect => { failures => 1 }, runlog => [ [ '_runtests', - { failures => 1, - verbosity => 0 + { failures => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -628,8 +654,9 @@ BEGIN { # START PLAN expect => { failures => 1 }, runlog => [ [ '_runtests', - { failures => 1, - verbosity => 0 + { failures => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -646,7 +673,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -663,7 +691,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( ['lib'] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -680,7 +709,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -697,7 +727,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { lib => mabs( [ 'blib/lib', 'blib/arch' ] ), - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -713,7 +744,9 @@ BEGIN { # START PLAN expect => { shuffle => 1 }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', "xxx$dummy_test" ] @@ -728,7 +761,9 @@ BEGIN { # START PLAN expect => { shuffle => 1 }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', "xxx$dummy_test" ] @@ -743,8 +778,9 @@ BEGIN { # START PLAN expect => { color => 1 }, runlog => [ [ '_runtests', - { color => 1, - verbosity => 0 + { color => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -760,7 +796,9 @@ BEGIN { # START PLAN expect => { recurse => 1 }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -775,7 +813,9 @@ BEGIN { # START PLAN expect => { recurse => 1 }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -790,7 +830,9 @@ BEGIN { # START PLAN expect => { backwards => 1 }, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', reverse @dummy_tests ] @@ -807,8 +849,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { errors => 1, - verbosity => 0 + { errors => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -826,8 +869,9 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { errors => 1, - verbosity => 0 + { errors => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -843,7 +887,8 @@ BEGIN { # START PLAN expect => { quiet => 1 }, runlog => [ [ '_runtests', - { verbosity => -1 + { verbosity => -1, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -859,7 +904,8 @@ BEGIN { # START PLAN expect => { quiet => 1 }, runlog => [ [ '_runtests', - { verbosity => -1 + { verbosity => -1, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -875,7 +921,8 @@ BEGIN { # START PLAN expect => { really_quiet => 1 }, runlog => [ [ '_runtests', - { verbosity => -2 + { verbosity => -2, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -891,7 +938,8 @@ BEGIN { # START PLAN expect => { really_quiet => 1 }, runlog => [ [ '_runtests', - { verbosity => -2 + { verbosity => -2, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -907,8 +955,9 @@ BEGIN { # START PLAN expect => { merge => 1 }, runlog => [ [ '_runtests', - { merge => 1, - verbosity => 0 + { merge => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -924,8 +973,9 @@ BEGIN { # START PLAN expect => { merge => 1 }, runlog => [ [ '_runtests', - { merge => 1, - verbosity => 0 + { merge => 1, + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -942,7 +992,8 @@ BEGIN { # START PLAN runlog => [ [ '_runtests', { directives => 1, - verbosity => 0 + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -958,7 +1009,11 @@ BEGIN { # START PLAN switches => [ '--exec', '-s', $dummy_test ], expect => { exec => '-s' }, runlog => [ - [ '_runtests', { exec => ['-s'], verbosity => 0 }, + [ '_runtests', + { exec => ['-s'], + verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -974,8 +1029,9 @@ BEGIN { # START PLAN expect => { exec => '/foo/bar/perl -Ilib' }, runlog => [ [ '_runtests', - { exec => [qw(/foo/bar/perl -Ilib)], - verbosity => 0 + { exec => [qw(/foo/bar/perl -Ilib)], + verbosity => 0, + show_count => 1, }, 'TAP::Harness', $dummy_test @@ -992,7 +1048,10 @@ BEGIN { # START PLAN }, runlog => [ [ '_runtests', - { exec => [], verbosity => 0 }, + { exec => [], + verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -1016,7 +1075,9 @@ BEGIN { # START PLAN plan => 1, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -1043,7 +1104,9 @@ BEGIN { # START PLAN plan => 1, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -1066,7 +1129,9 @@ BEGIN { # START PLAN plan => 1, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] @@ -1089,7 +1154,9 @@ BEGIN { # START PLAN plan => 1, runlog => [ [ '_runtests', - { verbosity => 0 }, + { verbosity => 0, + show_count => 1, + }, 'TAP::Harness', $dummy_test ] diff --git a/ext/Test/Harness/t/proverc.t b/ext/Test/Harness/t/proverc.t index df4cbbb..ec2d618 100644 --- a/ext/Test/Harness/t/proverc.t +++ b/ext/Test/Harness/t/proverc.t @@ -20,7 +20,12 @@ my $prove = App::Prove->new; $prove->add_rc_file( File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), 't', 'data', 'proverc' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', 'data', + 'proverc' ) ); diff --git a/ext/Test/Harness/t/proverun.t b/ext/Test/Harness/t/proverun.t index 7db0197..aafe8a5 100644 --- a/ext/Test/Harness/t/proverun.t +++ b/ext/Test/Harness/t/proverun.t @@ -19,29 +19,50 @@ my @SCHEDULE; BEGIN { - my $sample_test = File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'simple' + # to add a new test to proverun, just list the name of the file in + # t/sample-tests and a name for the test. The rest is handled + # automatically. + my @tests = ( + { file => 'simple', + name => 'Create empty', + }, + { file => 'todo_inline', + name => 'Passing TODO', + }, ); - + foreach my $test (@tests) { + + # let's fully expand that filename + $test->{file} = File::Spec->catfile( + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests', + $test->{file} + ); + } @SCHEDULE = ( - { name => 'Create empty', - args => [$sample_test], - expect => [ - [ 'new', - 'TAP::Parser::Iterator::Process', - { merge => undef, - command => [ - 'PERL', - $sample_test - ], - setup => \'CODE', - teardown => \'CODE', - - } + map { + { name => $_->{name}, + args => [ $_->{file} ], + expect => [ + [ 'new', + 'TAP::Parser::Iterator::Process', + { merge => undef, + command => [ + 'PERL', + $_->{file}, + ], + setup => \'CODE', + teardown => \'CODE', + + } + ] ] - ] - }, + } + } @tests ); plan tests => @SCHEDULE * 3; @@ -141,7 +162,7 @@ for my $test (@SCHEDULE) { # Why does this make the output from the test spew out of # our STDOUT? ok eval { $app->run }, 'run returned true'; - ok !$@, 'no errors'; + ok !$@, 'no errors' or diag $@; my @log = get_log(); diff --git a/ext/Test/Harness/t/regression.t b/ext/Test/Harness/t/regression.t index 8f93e4e..cd41ada 100644 --- a/ext/Test/Harness/t/regression.t +++ b/ext/Test/Harness/t/regression.t @@ -30,8 +30,12 @@ my $IsWin32 = $^O eq 'MSWin32'; my $SAMPLE_TESTS = File::Spec->catdir( File::Spec->curdir, - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests' ); my %deprecated = map { $_ => 1 } qw( diff --git a/ext/Test/Harness/t/sample-tests/delayed b/ext/Test/Harness/t/sample-tests/delayed index 94f667f..eb79d58 100644 --- a/ext/Test/Harness/t/sample-tests/delayed +++ b/ext/Test/Harness/t/sample-tests/delayed @@ -1,11 +1,5 @@ # Used to test Process.pm -BEGIN { - if ( $ENV{PERL_CORE} ) { - unshift @INC, '../lib'; - } -} - use Time::HiRes qw(sleep); my $delay = 0.01; diff --git a/ext/Test/Harness/t/sample-tests/inc_taint b/ext/Test/Harness/t/sample-tests/inc_taint index 223b535..d1be667 100644 --- a/ext/Test/Harness/t/sample-tests/inc_taint +++ b/ext/Test/Harness/t/sample-tests/inc_taint @@ -1,14 +1,5 @@ #!/usr/bin/perl -Tw -BEGIN { - if ( $ENV{PERL_CORE} ) { - unshift @INC, '../lib'; - } - else { - unshift @INC, 't/lib'; - } -} - use Test::More tests => 1; ok( grep( /examples/, @INC ) ); diff --git a/ext/Test/Harness/t/sample-tests/stdout_stderr b/ext/Test/Harness/t/sample-tests/stdout_stderr index 2f8ca38..ce17484 100644 --- a/ext/Test/Harness/t/sample-tests/stdout_stderr +++ b/ext/Test/Harness/t/sample-tests/stdout_stderr @@ -1,8 +1,3 @@ -BEGIN { - if ( $ENV{PERL_CORE} ) { - unshift @INC, '../lib'; - } -} use Test::More 'no_plan'; diag 'comments'; ok 1; diff --git a/ext/Test/Harness/t/source.t b/ext/Test/Harness/t/source.t index 99d81f9..b02475c 100644 --- a/ext/Test/Harness/t/source.t +++ b/ext/Test/Harness/t/source.t @@ -22,8 +22,13 @@ use TAP::Parser::Source::Perl; my $parser = EmptyParser->new; my $test = File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'source_tests', 'source' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'source_tests', + 'source' ); my $perl = $^X; diff --git a/ext/Test/Harness/t/state.t b/ext/Test/Harness/t/state.t index e6bfb7c..2808637 100644 --- a/ext/Test/Harness/t/state.t +++ b/ext/Test/Harness/t/state.t @@ -13,6 +13,7 @@ BEGIN { use strict; use Test::More; use App::Prove::State; +use App::Prove::State::Result; sub mn { my $pfx = $ENV{PERL_CORE} ? '../ext/Test/Harness/' : ''; @@ -150,6 +151,13 @@ my @schedule = ( 't/source.t', ], }, + { options => 'fresh', + get_tests_args => [], + expect => [ + 't/compat/env.t', + 't/compat/failure.t', + ], + }, ); plan tests => @schedule * 2; @@ -175,78 +183,80 @@ for my $test (@schedule) { } sub get_state { - return { - 'generation' => '51', - 'tests' => { - mn('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', - 'mtime' => 1196285623, - }, - mn('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', - 'mtime' => 1196285400, - }, - mn('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', - 'mtime' => 1196285739, - }, - mn('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', - 'mtime' => 1196285239, - }, - mn('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', - 'mtime' => 1196185639, - }, - mn('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', - 'mtime' => 1186285639, - }, + return App::Prove::State::Result->new( + { generation => 51, + last_run_time => 1196285439, + tests => { + mn('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, + mtime => 1196285623, + }, + mn('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, + mtime => 1196285400, + }, + mn('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, + mtime => 1196285739, + }, + mn('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, + mtime => 1196285239, + }, + mn('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, + mtime => 1196185639, + }, + mn('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, + mtime => 1186285639, + }, + } } - }; + ); } diff --git a/ext/Test/Harness/t/state_results.t b/ext/Test/Harness/t/state_results.t new file mode 100644 index 0000000..db532c9 --- /dev/null +++ b/ext/Test/Harness/t/state_results.t @@ -0,0 +1,154 @@ +#!/usr/bin/perl -w + +BEGIN { + if ( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = '../lib'; + } + else { + unshift @INC, 't/lib'; + } +} + +use strict; +use Test::More tests => 25; +use App::Prove::State; + +my $test_suite_data = test_suite_data(); + +# +# Test test suite results +# + +can_ok 'App::Prove::State::Result', 'new'; +isa_ok my $result = App::Prove::State::Result->new($test_suite_data), + 'App::Prove::State::Result', '... and the object it returns'; + +ok $result, 'state_version'; +ok defined $result->state_version, '... and it should be defined'; + +can_ok $result, 'generation'; +is $result->generation, $test_suite_data->{generation}, + '... and it should return the correct generation'; + +can_ok $result, 'num_tests'; +is $result->num_tests, scalar keys %{ $test_suite_data->{tests} }, + '... and it should return the number of tests run'; + +can_ok $result, 'raw'; +is_deeply $result->raw, $test_suite_data, + '... and it should return the raw, unblessed data'; + +# +# Check individual tests. +# + +can_ok $result, 'tests'; + +can_ok $result, 'test'; +eval { $result->test }; +my $error = $@; +like $error, qr/^\Qtest() requires a test name/, + '... and it should croak() if a test name is not supplied'; + +my $name = 't/compat/failure.t'; +ok my $test = $result->test('t/compat/failure.t'), + 'result() should succeed if the test name is found'; +isa_ok $test, 'App::Prove::State::Result::Test', + '... and the object it returns'; + +can_ok $test, 'name'; +is $test->name, $name, '... and it should return the test name'; + +can_ok $test, 'last_pass_time'; +like $test->last_pass_time, qr/^\d+\.\d+$/, + '... and it should return a numeric value'; + +can_ok $test, 'last_fail_time'; +ok !defined $test->last_fail_time, + '... and it should return undef if the test has never failed'; + +can_ok $result, 'remove'; +ok $result->remove($name), '... and calling it should succeed'; + +ok $test = $result->test($name), + '... and fetching the removed test should suceed'; +ok !defined $test->last_pass_time, '... and it should have clean values'; + +sub test_suite_data { + return { + 'version' => App::Prove::State::Result->state_version, + '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', + 'mtime' => 1196285623, + }, + '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', + 'mtime' => 1196285400, + }, + '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', + 'mtime' => 1196285739, + }, + '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', + 'mtime' => 1196285239, + }, + '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', + 'mtime' => 1196185639, + }, + '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', + 'mtime' => 1186285639, + }, + } + }; +} diff --git a/ext/Test/Harness/t/testargs.t b/ext/Test/Harness/t/testargs.t index 0c69f8a..7291992 100644 --- a/ext/Test/Harness/t/testargs.t +++ b/ext/Test/Harness/t/testargs.t @@ -14,8 +14,13 @@ use TAP::Harness; use App::Prove; my $test = File::Spec->catfile( - ( $ENV{PERL_CORE} ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) : () ), - 't', 'sample-tests', 'echo' + ( $ENV{PERL_CORE} + ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' ) + : () + ), + 't', + 'sample-tests', + 'echo' ); diag( "\n\n", bigness( join ' ', @ARGV ), "\n\n" ) if @ARGV; -- 2.7.4