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
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
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
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
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
'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'],
),
);
-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.
=head2 C<--state>
You can ask C<prove> to remember the state of previous test runs and
-select and/or order the tests to be run this time based on that
-saved state.
+select and/or order the tests to be run based on that saved state.
The C<--state> switch requires an argument which must be a comma
separated list of one or more of the following options.
=item C<new>
-Run the tests in newest to oldest order.
+Run the tests in newest to oldest order based on the modification times
+of the test scripts.
=item C<old>
Run the tests in oldest to newest order.
+=item C<fresh>
+
+Run those test scripts that have been modified since the last test run.
+
=item C<save>
Save the state on exit. The state is stored in a file called F<.prove>
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
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};
};
}
}
$self->{$key} = [];
}
$self->{harness_class} = 'TAP::Harness';
- $self->{_state} = App::Prove::State->new( { store => STATE_FILE } );
for my $attr (@ATTR) {
if ( exists $args->{$attr} ) {
while ( my ( $env, $attr ) = each %env_provides_default ) {
$self->{$attr} = 1 if $ENV{$env};
}
+ $self->state_manager(
+ $self->state_class->new( { store => STATE_FILE } ) );
return $self;
}
+=head3 C<state_class>
+
+Returns the name of the class used for maintaining state. This class should
+either subclass from C<App::Prove::State> or provide an identical interface.
+
+=head3 C<state_manager>
+
+Getter/setter for the an instane of the C<state_class>.
+
+=cut
+
+sub state_class {
+ return 'App::Prove::State';
+}
+
=head3 C<add_rc_file>
$prove->add_rc_file('myproj/.proverc');
'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},
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' );
for my $pfx (@search) {
my $name = join( '::', $pfx, $class );
- print "$name\n";
eval "require $name";
return $name unless $@;
}
my $app = App::Prove->new;
$app->process_args(@ARGV);
- $app->run;
+ exit( $app->run ? 0 : 1 ); # if you need the exit code
=cut
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 ) ) {
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 {
=item C<rules>
+=item C<show_count>
+
=item C<show_help>
=item C<show_man>
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;
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
my %args = %{ shift || {} };
my $self = bless {
- _ => {
- tests => {},
- generation => 1
- },
+ _ => $class->result_class->new(
+ { tests => {},
+ generation => 1,
+ }
+ ),
select => [],
seq => 1,
store => delete $args{store},
return $self;
}
+=head2 C<result_class>
+
+Returns the name of the class used for tracking test results. This class
+should either subclass from C<App::Prove::State::Result> or provide an
+identical interface.
+
+=cut
+
+sub result_class {
+ return 'App::Prove::State::Result';
+}
+
=head2 C<extension>
Get or set the extension files must have in order to be considered
return $self->{extension};
}
-sub DESTROY {
+=head2 C<results>
+
+Get the results of the last test run. Returns a C<result_class()> instance.
+
+=cut
+
+sub results {
+ my $self = shift;
+ $self->{_} || $self->result_class->new
+}
+
+=head2 C<commit>
+
+Save the test results. Should be called after all tests have run.
+
+=cut
+
+sub commit {
my $self = shift;
if ( $self->{should_save} && defined( my $store = $self->{store} ) ) {
$self->save($store);
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}++;
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;
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
|| ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
} map {
[ $_,
- do { local $_ = $tests->{$_}; $order->() }
+ do { local $_ = $results->test($_); $order->() }
]
} @got;
}
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;
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,
);
}
# 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);
}
}
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;
}
my $reader = TAP::Parser::YAMLish::Reader->new;
local *FH;
open FH, "<$name" or croak "Can't read $name ($!)";
- $self->{_} = $reader->read(
- sub {
- my $line = <FH>;
- defined $line && chomp $line;
- return $line;
- }
+
+ # XXX this is temporary
+ $self->{_} = $self->result_class->new(
+ $reader->read(
+ sub {
+ my $line = <FH>;
+ defined $line && chomp $line;
+ return $line;
+ }
+ )
);
# $writer->write( $self->{tests} || {}, \*FH );
close FH;
$self->_regen_seq;
$self->_prune_and_stamp;
- $self->{_}->{generation}++;
+ $self->results->generation( $self->results->generation + 1 );
}
sub _prune_and_stamp {
my $self = shift;
- for my $name ( keys %{ $self->{_}->{tests} || {} } ) {
+
+ my $results = $self->results;
+ my @tests = $self->results->tests;
+ for my $test (@tests) {
+ my $name = $test->name;
if ( my @stat = stat $name ) {
- $self->{_}->{tests}->{$name}->{mtime} = $stat[9];
+ $test->mtime( $stat[9] );
}
else {
- delete $self->{_}->{tests}->{$name};
+ $results->remove($name);
}
}
}
sub _regen_seq {
my $self = shift;
- for my $rec ( values %{ $self->{_}->{tests} || {} } ) {
- $self->{seq} = $rec->{seq} + 1
- if defined $rec->{seq} && $rec->{seq} >= $self->{seq};
+ for my $test ( $self->results->tests ) {
+ $self->{seq} = $test->sequence + 1
+ if defined $test->sequence && $test->sequence >= $self->{seq};
}
}
+
+1;
--- /dev/null
+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<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test suite run.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+ my $result = App::Prove::State::Result->new({
+ generation => $generation,
+ tests => \%tests,
+ });
+
+Returns a new C<App::Prove::State::Result> instance.
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ my %instance_data = %$arg_for; # shallow copy
+ $instance_data{version} = $class->state_version;
+ my $tests = delete $instance_data{tests} || {};
+ my $self = bless \%instance_data => $class;
+ $self->_initialize($tests);
+ return $self;
+}
+
+sub _initialize {
+ my ( $self, $tests ) = @_;
+ my %tests;
+ while ( my ( $name, $test ) = each %$tests ) {
+ $tests{$name} = $self->test_class->new({
+ %$test,
+ name => $name
+ });
+ }
+ $self->tests( \%tests );
+ return $self;
+}
+
+=head2 C<state_version>
+
+Returns the current version of state storage.
+
+=cut
+
+sub state_version {STATE_VERSION}
+
+=head2 C<test_class>
+
+Returns the name of the class used for tracking individual tests. This class
+should either subclass from C<App::Prove::State::Result::Test> or provide an
+identical interface.
+
+=cut
+
+sub test_class {
+ return 'App::Prove::State::Result::Test';
+}
+
+my %methods = (
+ generation => { method => 'generation', default => 0 },
+ last_run_time => { method => 'last_run_time', default => undef },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head3 C<generation>
+
+Getter/setter for the "generation" of the test suite run. The first
+generation is 1 (one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_run_time>
+
+Getter/setter for the time of the test suite run.
+
+=head3 C<tests>
+
+Returns the tests for a given generation. This is a hashref or a hash,
+depending on context called. The keys to the hash are the individual
+test names and the value is a hashref with various interesting values.
+Each k/v pair might resemble something like this:
+
+ 't/foo.t' => {
+ elapsed => '0.0428488254547119',
+ gen => '7',
+ last_pass_time => '1219328376.07815',
+ last_result => '0',
+ last_run_time => '1219328376.07815',
+ last_todo => '0',
+ mtime => '1191708862',
+ seq => '192',
+ total_passes => '6',
+ }
+
+=cut
+
+sub tests {
+ my $self = shift;
+ if (@_) {
+ $self->{tests} = shift;
+ return $self;
+ }
+ my %tests = %{ $self->{tests} };
+ my @tests = sort { $a->sequence <=> $b->sequence } values %tests;
+ return wantarray ? @tests : \@tests;
+}
+
+=head3 C<test>
+
+ my $test = $result->test('t/customer/create.t');
+
+Returns an individual C<App::Prove::State::Result::Test> instance for the
+given test name (usually the filename). Will return a new
+C<App::Prove::State::Result::Test> instance if the name is not found.
+
+=cut
+
+sub test {
+ my ( $self, $name ) = @_;
+ croak("test() requires a test name") unless defined $name;
+
+ my $tests = $self->{tests} ||= {};
+ if ( my $test = $tests->{$name} ) {
+ return $test;
+ }
+ else {
+ my $test = $self->test_class->new({name => $name});
+ $self->{tests}->{$name} = $test;
+ return $test;
+ }
+}
+
+=head3 C<test_names>
+
+Returns an list of test names, sorted by run order.
+
+=cut
+
+sub test_names {
+ my $self = shift;
+ return map { $_->name } $self->tests;
+}
+
+=head3 C<remove>
+
+ $result->remove($test_name); # remove the test
+ my $test = $result->test($test_name); # fatal error
+
+Removes a given test from results. This is a no-op if the test name is not
+found.
+
+=cut
+
+sub remove {
+ my ( $self, $name ) = @_;
+ delete $self->{tests}->{$name};
+ return $self;
+}
+
+=head3 C<num_tests>
+
+Returns the number of tests for a given test suite result.
+
+=cut
+
+sub num_tests { keys %{ shift->{tests} } }
+
+=head3 C<raw>
+
+Returns a hashref of raw results, suitable for serialization by YAML.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ my %tests;
+ foreach my $test ( $self->tests ) {
+ $tests{ $test->name } = $test->raw;
+ }
+ $raw{tests} = \%tests;
+ return \%raw;
+}
+
+1;
--- /dev/null
+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<prove> command supports a C<--state> option that instructs it to
+store persistent state across runs. This module encapsulates the results for a
+single test.
+
+=head1 SYNOPSIS
+
+ # Re-run failed tests
+ $ prove --state=fail,save -rbv
+
+=cut
+
+my %methods = (
+ name => { method => 'name' },
+ elapsed => { method => 'elapsed', default => 0 },
+ gen => { method => 'generation', default => 1 },
+ last_pass_time => { method => 'last_pass_time', default => undef },
+ last_fail_time => { method => 'last_fail_time', default => undef },
+ last_result => { method => 'result', default => 0 },
+ last_run_time => { method => 'run_time', default => undef },
+ last_todo => { method => 'num_todo', default => 0 },
+ mtime => { method => 'mtime', default => undef },
+ seq => { method => 'sequence', default => 1 },
+ total_passes => { method => 'total_passes', default => 0 },
+ total_failures => { method => 'total_failures', default => 0 },
+);
+
+while ( my ( $key, $description ) = each %methods ) {
+ my $default = $description->{default};
+ no strict 'refs';
+ *{ $description->{method} } = sub {
+ my $self = shift;
+ if (@_) {
+ $self->{$key} = shift;
+ return $self;
+ }
+ return $self->{$key} || $default;
+ };
+}
+
+=head1 METHODS
+
+=head2 Class Methods
+
+=head3 C<new>
+
+=cut
+
+sub new {
+ my ( $class, $arg_for ) = @_;
+ $arg_for ||= {};
+ bless $arg_for => $class;
+}
+
+=head2 Instance Methods
+
+=head3 C<name>
+
+The name of the test. Usually a filename.
+
+=head3 C<elapsed>
+
+The total elapsed times the test took to run, in seconds from the epoch..
+
+=head3 C<generation>
+
+The number for the "generation" of the test run. The first generation is 1
+(one) and subsequent generations are 2, 3, etc.
+
+=head3 C<last_pass_time>
+
+The last time the test program passed, in seconds from the epoch.
+
+Returns C<undef> if the program has never passed.
+
+=head3 C<last_fail_time>
+
+The last time the test suite failed, in seconds from the epoch.
+
+Returns C<undef> if the program has never failed.
+
+=head3 C<mtime>
+
+Returns the mtime of the test, in seconds from the epoch.
+
+=head3 C<raw>
+
+Returns a hashref of raw test data, suitable for serialization by YAML.
+
+=head3 C<result>
+
+Currently, whether or not the test suite passed with no 'problems' (such as
+TODO passed).
+
+=head3 C<run_time>
+
+The total time it took for the test to run, in seconds. If C<Time::HiRes> is
+available, it will have finer granularity.
+
+=head3 C<num_todo>
+
+The number of tests with TODO directives.
+
+=head3 C<sequence>
+
+The order in which this test was run for the given test suite result.
+
+=head3 C<total_passes>
+
+The number of times the test has passed.
+
+=head3 C<total_failures>
+
+The number of times the test has failed.
+
+=cut
+
+sub raw {
+ my $self = shift;
+ my %raw = %$self;
+
+ # this is backwards-compatibility hack and is not gauranteed.
+ delete $raw{name};
+ return \%raw;
+}
+
+1;
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
my $GOT_TIME_HIRES;
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
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")
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
The number of concurrent jobs this formatter will handle.
+=item * C<show_count>
+
+Boolean value. If false, disables the C<X/Y> test count which shows up while
+tests are running.
+
=back
Any keys for which the value is C<undef> will be ignored.
$self->_croak($@) if $@;
my $session = $class->new(
- { name => $test,
- formatter => $self,
- parser => $parser
+ { name => $test,
+ formatter => $self,
+ parser => $parser,
+ show_count => $self->show_count,
}
);
};
}
-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<TAP::Harness::Parallel>.
+This provides console orientated output formatting for L<TAP::Harness>
+when run with multiple L<TAP::Harness/jobs>.
=head1 SYNOPSIS
=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<result>
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<clear_for_close>
- 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;
}
}
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;
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};
}
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';
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=item * C<name>
+=item * C<show_count>
+
=back
=cut
$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)");
}
Called to close a test session.
+=head3 C<clear_for_close>
+
+Called by C<close_test> to clear the line showing test progress, or the parallel
+test ruler, prior to printing the final test result.
+
=cut
sub _get_output_result {
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;
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;
}
}
},
+ 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);
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");
}
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);
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
$ENV{HARNESS_ACTIVE} = 1;
$ENV{HARNESS_VERSION} = $VERSION;
BEGIN {
@FORMATTER_ARGS = qw(
- directives verbosity timer failures errors stdout color
+ directives verbosity timer failures errors stdout color show_count
);
%VALIDATION_FOR = (
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 ) {
)
my $harness = TAP::Harness->new( \%args );
-The constructor returns a new C<TAP::Harness> object. It accepts an optional
-hashref whose allowed keys are:
+The constructor returns a new C<TAP::Harness> object. It accepts an
+optional hashref whose allowed keys are:
=over 4
-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<timer>
-Append run time for each test to output. Uses L<Time::HiRes> if available.
+Append run time for each test to output. Uses L<Time::HiRes> if
+available.
=item * C<failures>
Only show test failures (this is a no-op if C<verbose> is selected).
+=item * C<show_count>
+
+Update the running test count during testing.
+
=item * C<lib>
-Accepts a scalar value or array ref of scalar values indicating which paths to
-allowed libraries should be included if Perl tests are executed. Naturally,
-this only makes sense in the context of tests written in Perl.
+Accepts a scalar value or array ref of scalar values indicating which
+paths to allowed libraries should be included if Perl tests are
+executed. Naturally, this only makes sense in the context of tests
+written in Perl.
=item * C<switches>
-Accepts a scalar value or array ref of scalar values indicating which switches
-should be included if Perl tests are executed. Naturally, this only makes
-sense in the context of tests written in Perl.
+Accepts a scalar value or array ref of scalar values indicating which
+switches should be included if Perl tests are executed. Naturally, this
+only makes sense in the context of tests written in Perl.
=item * C<test_args>
=item * C<exec>
-Typically, Perl tests are run through this. However, anything which spits out
-TAP is fine. You can use this argument to specify the name of the program
-(and optional switches) to run your tests with:
+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<undef>, 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<undef>, 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<merge>
If C<merge> is true the harness will create parsers that merge STDOUT
and STDERR together for any processes they start.
+=item * C<aggregator_class>
+
+The name of the class to use to aggregate test results. The default is
+L<TAP::Parser::Aggregator>.
+
=item * C<formatter_class>
The name of the class to use to format output. The default is
L<TAP::Formatter::Console>.
+=item * C<multiplexer_class>
+
+The name of the class to use to multiplex tests during parallel testing.
+The default is L<TAP::Parser::Multiplexer>.
+
+=item * C<parser_class>
+
+The name of the class to use to parse TAP. The default is
+L<TAP::Parser>.
+
+=item * C<scheduler_class>
+
+The name of the class to use to schedule test execution. The default is
+L<TAP::Parser::Scheduler>.
+
=item * C<formatter>
If set C<formatter> must be an object that is capable of formatting the
=item * C<errors>
-If parse errors are found in the TAP output, a note of this will be made
-in the summary report. To see all of the parse errors, set this argument to
-true:
+If parse errors are found in the TAP output, a note of this will be
+made in the summary report. To see all of the parse errors, set this
+argument to true:
errors => 1
=item * C<directives>
-If set to a true value, only test results with directives will be displayed.
-This overrides other settings such as C<verbose> or C<failures>.
+If set to a true value, only test results with directives will be
+displayed. This overrides other settings such as C<verbose> or
+C<failures>.
=item * C<ignore_exit>
If set to a true value instruct C<TAP::Parser> to ignore exit and wait
status from test scripts.
+=item * C<jobs>
+
+The maximum number of parallel tests to run at any time. Which tests
+can be run in parallel is controlled by C<rules>. The default is to
+run only one test at a time.
+
+=item * C<fork>
+
+If true the harness will attempt to fork and run the parser for each
+test in a separate process. Currently this option requires
+L<Parallel::Iterator> to be installed.
+
=item * C<rules>
A reference to a hash of rules that control which tests may be
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 ||= {};
$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
}
}
- $self->formatter( $class->new( \%formatter_args ) );
+ $self->formatter(
+ $self->_construct( $self->formatter_class, \%formatter_args )
+ );
}
if ( my @props = sort keys %arg_for ) {
$harness->runtests(@tests);
-Accepts and array of C<@tests> to be run. This should generally be the names
-of test files, but this is not required. Each element in C<@tests> will be
-passed to C<TAP::Parser::new()> as a C<source>. See L<TAP::Parser> for more
-information.
+Accepts and array of C<@tests> to be run. This should generally be the
+names of test files, but this is not required. Each element in C<@tests>
+will be passed to C<TAP::Parser::new()> as a C<source>. See
+L<TAP::Parser> for more information.
It is possible to provide aliases that will be displayed in place of the
test name by supplying the test as a reference to an array containing
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;
my ( $self, $aggregate, $scheduler ) = @_;
my $jobs = $self->jobs;
- my $mux = TAP::Parser::Multiplexer->new;
+ my $mux = $self->_construct( $self->multiplexer_class );
RESULT: {
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<runtests>.
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
);
=head3 C<jobs>
-Returns the number of concurrent test runs the harness is handling. For the default
-harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
-will override this to return the number of jobs it is handling.
+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<TAP::Harness::Parallel> will override this to return the number of
+jobs it is handling.
=head3 C<fork>
=head1 SUBCLASSING
-C<TAP::Harness> is designed to be (mostly) easy to subclass. If you don't
-like how a particular feature functions, just override the desired methods.
+C<TAP::Harness> is designed to be (mostly) easy to subclass. If you
+don't like how a particular feature functions, just override the
+desired methods.
=head2 Methods
$harness->summary( \%args );
-C<summary> prints the summary report after all tests are run. The argument is
-a hashref with the following keys:
+C<summary> prints the summary report after all tests are run. The
+argument is a hashref with the following keys:
=over 4
=item * C<start>
-This is created with C<< Benchmark->new >> and it the time the tests started.
-You can print a useful summary time, if desired, with:
+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<tests>
-This is an array reference of all test names. To get the L<TAP::Parser>
+This is an array reference of all test names. To get the L<TAP::Parser>
object for individual tests:
my $aggregate = $args->{aggregate};
my ( $parser, $session ) = $harness->make_parser;
-
=cut
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 );
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
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;
=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;
Steve Purkis <spurkis@cpan.org>
+Nicholas Clark <nick@ccl4.org>
+
=head1 BUGS
Please report any bugs or feature requests to
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
( $desc, $dir, $explanation ) = ( $1, $2, $3 );
}
return $self->_make_test_token(
- $line, $ok, $num, $desc,
- $dir, $explanation
+ $line, $ok, $num, $desc,
+ $dir, $explanation
);
},
},
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 {
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
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;
}
L<TAP::Parser::Result::Test>,
L<TAP::Parser::Result::Unknown>,
L<TAP::Parser::Result::Version>,
-L<TAP::PARSER::RESULT::YAML>,
+L<TAP::Parser::Result::YAML>,
=cut
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head2 DESCRIPTION
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
);
}
+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 ) {
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<get_job>
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;
}
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;
}
}
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
return bless {
filename => $name,
description => $desc,
- context => \@ctx,
+ @ctx ? ( context => \@ctx ) : (),
}, $class;
}
sub filename { shift->{filename} }
sub description { shift->{description} }
-sub context { @{ shift->{context} } }
+sub context { @{ shift->{context} || [] } }
=head3 C<as_array_ref>
sub as_array_ref {
my $self = shift;
- return [ $self->filename, $self->description, $self->context ];
+ return [ $self->filename, $self->description, $self->{context} ||= [] ];
}
=head3 C<is_spinner>
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
use constant IS_VMS => ( $^O eq 'VMS' );
use TAP::Parser::Source;
+use TAP::Parser::Utils qw( split_shell );
+
@ISA = 'TAP::Parser::Source';
=head1 NAME
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
# 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)
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
=head1 SYNOPSIS
use TAP::Object ();
@ISA = 'TAP::Object';
-$VERSION = '3.13';
+$VERSION = '3.14';
# TODO:
# Handle blessed object syntax
=head1 VERSION
-Version 3.13
+Version 3.14
=head1 SYNOPSIS
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;
}
}
else {
- die "Don't know how to enocde $ref";
+ die "Don't know how to encode $ref";
}
}
else {
=head1 VERSION
-Version 3.13
+Version 3.14
=head1 SYNOPSIS
=head1 VERSION
-Version 3.13
+Version 3.14
=cut
-$VERSION = '3.13';
+$VERSION = '3.14';
# Backwards compatibility for exportable variable names.
*verbose = *Verbose;
elsif (IS_WIN32) {
# Lose any trailing backslashes in the Win32 paths
- s/[\\\/+]$// foreach @inc;
+ s/[\\\/]+$// foreach @inc;
}
my @default_inc = _default_inc();
use strict;
use lib 't/lib';
-use Test::More tests => 74;
+use Test::More tests => 78;
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
}
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' );
}
{
#!/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 = {
)
) => {
'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' => ''
}
},
},
'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'
}
},
},
'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'
}
},
},
'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'
}
},
},
'duplicates' => {
'failed' => {
- 't/sample-tests/duplicates' => {
+ "$TEST_DIR/duplicates" => {
'canon' => '??',
'estat' => '',
'failed' => '??',
'max' => 10,
- 'name' => 't/sample-tests/duplicates',
+ 'name' => "$TEST_DIR/duplicates",
'wstat' => ''
}
},
},
'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' => ''
}
},
},
'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'
}
},
},
'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' => ''
}
},
},
'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' => ''
}
},
},
'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' => ''
}
},
( $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' => ''
}
},
'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' => ''
}
},
},
'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' => ''
}
},
},
'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'
}
},
},
'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' => ''
}
},
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;
}
{
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+
+use Test::More;
+
+require TAP::Parser::Scheduler;
+
+my @tests;
+while (<DATA>) {
+ 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
--- /dev/null
+#!/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';
+}
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;
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'
);
};
# 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
{ 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',
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,
--- /dev/null
+package NOP;
+
+# Do nothing much
+
+sub new { bless {}, shift }
+
+1;
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'
),
}
),
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'
),
}
),
( 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'
),
}
),
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
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'
),
}
);
);
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 ) {
expect => {},
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
- 'one',
- 'two',
- 'three'
+ 'one', 'two', 'three'
]
],
},
},
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0, show_count => 1 },
'TAP::Harness',
'one', 'two',
'three'
runlog => [
[ '_runtests',
{ lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { color => 1,
- verbosity => 0
+ { color => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
runlog => [
[ '_runtests',
{ directives => 1,
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { exec => [1],
- verbosity => 0
+ { exec => [1],
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { failures => 1,
- verbosity => 0
+ { failures => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
runlog => [
[ '_runtests',
{ formatter_class => 'TAP::Harness',
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
runlog => [
[ '_runtests',
{ lib => mabs( [qw( four five six )] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
runlog => [
[ '_runtests',
{ lib => mabs( ['lib'] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { merge => 1,
- verbosity => 0
+ { merge => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { errors => 1,
- verbosity => 0
+ { errors => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { verbosity => -1
+ { verbosity => -1,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { verbosity => -2
+ { verbosity => -2,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
'one', 'two', 'three'
]
},
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
'three', 'two', 'one'
]
},
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
'xxxone', 'xxxtwo',
'xxxthree'
},
runlog => [
[ '_runtests',
- { switches => ['-T'],
- verbosity => 0
+ { switches => ['-T'],
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { switches => ['-t'],
- verbosity => 0
+ { switches => ['-t'],
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { verbosity => 1
+ { verbosity => 1,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { switches => ['-W'],
- verbosity => 0
+ { switches => ['-W'],
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { switches => ['-w'],
- verbosity => 0
+ { switches => ['-w'],
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
'one', 'two', 'three'
},
runlog => [
[ '_runtests',
- { verbosity => 1
+ { verbosity => 1,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
},
runlog => [
[ '_runtests',
- { verbosity => 1
+ { verbosity => 1,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { failures => 1 },
runlog => [
[ '_runtests',
- { failures => 1,
- verbosity => 0
+ { failures => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { failures => 1 },
runlog => [
[ '_runtests',
- { failures => 1,
- verbosity => 0
+ { failures => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
runlog => [
[ '_runtests',
{ lib => mabs( ['lib'] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
runlog => [
[ '_runtests',
{ lib => mabs( ['lib'] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
runlog => [
[ '_runtests',
{ lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
runlog => [
[ '_runtests',
{ lib => mabs( [ 'blib/lib', 'blib/arch' ] ),
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { shuffle => 1 },
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
"xxx$dummy_test"
]
expect => { shuffle => 1 },
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
"xxx$dummy_test"
]
expect => { color => 1 },
runlog => [
[ '_runtests',
- { color => 1,
- verbosity => 0
+ { color => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { recurse => 1 },
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
expect => { recurse => 1 },
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
expect => { backwards => 1 },
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
reverse @dummy_tests
]
},
runlog => [
[ '_runtests',
- { errors => 1,
- verbosity => 0
+ { errors => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
},
runlog => [
[ '_runtests',
- { errors => 1,
- verbosity => 0
+ { errors => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { quiet => 1 },
runlog => [
[ '_runtests',
- { verbosity => -1
+ { verbosity => -1,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { quiet => 1 },
runlog => [
[ '_runtests',
- { verbosity => -1
+ { verbosity => -1,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { really_quiet => 1 },
runlog => [
[ '_runtests',
- { verbosity => -2
+ { verbosity => -2,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { really_quiet => 1 },
runlog => [
[ '_runtests',
- { verbosity => -2
+ { verbosity => -2,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { merge => 1 },
runlog => [
[ '_runtests',
- { merge => 1,
- verbosity => 0
+ { merge => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
expect => { merge => 1 },
runlog => [
[ '_runtests',
- { merge => 1,
- verbosity => 0
+ { merge => 1,
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
runlog => [
[ '_runtests',
{ directives => 1,
- verbosity => 0
+ verbosity => 0,
+ show_count => 1,
},
'TAP::Harness',
$dummy_test
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
]
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
},
runlog => [
[ '_runtests',
- { exec => [], verbosity => 0 },
+ { exec => [],
+ verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
plan => 1,
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
plan => 1,
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
plan => 1,
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
plan => 1,
runlog => [
[ '_runtests',
- { verbosity => 0 },
+ { verbosity => 0,
+ show_count => 1,
+ },
'TAP::Harness',
$dummy_test
]
$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'
)
);
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;
# 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();
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(
# Used to test Process.pm
-BEGIN {
- if ( $ENV{PERL_CORE} ) {
- unshift @INC, '../lib';
- }
-}
-
use Time::HiRes qw(sleep);
my $delay = 0.01;
#!/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 ) );
-BEGIN {
- if ( $ENV{PERL_CORE} ) {
- unshift @INC, '../lib';
- }
-}
use Test::More 'no_plan';
diag 'comments';
ok 1;
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;
use strict;
use Test::More;
use App::Prove::State;
+use App::Prove::State::Result;
sub mn {
my $pfx = $ENV{PERL_CORE} ? '../ext/Test/Harness/' : '';
't/source.t',
],
},
+ { options => 'fresh',
+ get_tests_args => [],
+ expect => [
+ 't/compat/env.t',
+ 't/compat/failure.t',
+ ],
+ },
);
plan tests => @schedule * 2;
}
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,
+ },
+ }
}
- };
+ );
}
--- /dev/null
+#!/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,
+ },
+ }
+ };
+}
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff