diff options
Diffstat (limited to 'ext/Test-Harness/lib/App')
| -rw-r--r-- | ext/Test-Harness/lib/App/Prove.pm | 141 | ||||
| -rw-r--r-- | ext/Test-Harness/lib/App/Prove/State.pm | 85 | ||||
| -rw-r--r-- | ext/Test-Harness/lib/App/Prove/State/Result.pm | 15 | ||||
| -rw-r--r-- | ext/Test-Harness/lib/App/Prove/State/Result/Test.pm | 13 |
4 files changed, 183 insertions, 71 deletions
diff --git a/ext/Test-Harness/lib/App/Prove.pm b/ext/Test-Harness/lib/App/Prove.pm index 29d2f8fd1f..bc665fac56 100644 --- a/ext/Test-Harness/lib/App/Prove.pm +++ b/ext/Test-Harness/lib/App/Prove.pm @@ -11,19 +11,17 @@ use Getopt::Long; use App::Prove::State; use Carp; -@ISA = qw(TAP::Object); - =head1 NAME App::Prove - Implements the C<prove> command. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -53,21 +51,16 @@ use constant PLUGINS => 'App::Prove::Plugin'; my @ATTR; BEGIN { + @ISA = qw(TAP::Object); + @ATTR = qw( archive argv blib show_count color directives exec failures fork formatter harness includes modules plugins jobs lib merge parse quiet really_quiet recurse backwards shuffle taint_fail taint_warn timer verbose warnings_fail warnings_warn show_help show_man show_version - test_args state dry extension ignore_exit rules state_manager + state_class test_args state dry extension ignore_exit rules state_manager ); - for my $attr (@ATTR) { - no strict 'refs'; - *$attr = sub { - my $self = shift; - $self->{$attr} = shift if @_; - return $self->{$attr}; - }; - } + __PACKAGE__->mk_methods(@ATTR); } =head1 METHODS @@ -108,27 +101,22 @@ sub _initialize { while ( my ( $env, $attr ) = each %env_provides_default ) { $self->{$attr} = 1 if $ENV{$env}; } - $self->state_manager( - $self->state_class->new( { store => STATE_FILE } ) ); - + $self->state_class('App::Prove::State'); return $self; } =head3 C<state_class> -Returns the name of the class used for maintaining state. This class should -either subclass from C<App::Prove::State> or provide an identical interface. +Getter/setter for the name of the class used for maintaining state. This +class should either subclass from C<App::Prove::State> or provide an identical +interface. =head3 C<state_manager> -Getter/setter for the an instane of the C<state_class>. +Getter/setter for the instance of the C<state_class>. =cut -sub state_class { - return 'App::Prove::State'; -} - =head3 C<add_rc_file> $prove->add_rc_file('myproj/.proverc'); @@ -400,19 +388,22 @@ sub _find_module { } sub _load_extension { - my ( $self, $class, @search ) = @_; + my ( $self, $name, @search ) = @_; my @args = (); - if ( $class =~ /^(.*?)=(.*)/ ) { - $class = $1; + if ( $name =~ /^(.*?)=(.*)/ ) { + $name = $1; @args = split( /,/, $2 ); } - if ( my $name = $self->_find_module( $class, @search ) ) { - $name->import(@args); + if ( my $class = $self->_find_module( $name, @search ) ) { + $class->import(@args); + if ( $class->can('load') ) { + $class->load( { app_prove => $self, args => [@args] } ); + } } else { - croak "Can't load module $class"; + croak "Can't load module $name"; } } @@ -437,6 +428,11 @@ command line tool consists of the following code: sub run { my $self = shift; + unless ( $self->state_manager ) { + $self->state_manager( + $self->state_class->new( { store => STATE_FILE } ) ); + } + if ( $self->show_help ) { $self->_help(1); } @@ -675,6 +671,8 @@ calling C<run>. =item C<state> +=item C<state_class> + =item C<taint_fail> =item C<taint_warn> @@ -690,3 +688,88 @@ calling C<run>. =item C<warnings_warn> =back + +=head1 PLUGINS + +C<App::Prove> provides support for 3rd-party plugins. These are currently +loaded at run-time, I<after> arguments have been parsed (so you can not +change the way arguments are processed, sorry), typically with the +C<< -PI<plugin> >> switch, eg: + + prove -PMyPlugin + +This will search for a module named C<App::Prove::Plugin::MyPlugin>, or failing +that, C<MyPlugin>. If the plugin can't be found, C<prove> will complain & exit. + +You can pass an argument to your plugin by appending an C<=> after the plugin +name, eg C<-PMyPlugin=foo>. You can pass multiple arguments using commas: + + prove -PMyPlugin=foo,bar,baz + +These are passed in to your plugin's C<load()> class method (if it has one), +along with a reference to the C<App::Prove> object that is invoking your plugin: + + sub load { + my ($class, $p) = @_; + + my @args = @{ $p->{args} }; + # @args will contain ( 'foo', 'bar', 'baz' ) + $p->{app_prove}->do_something; + ... + } + +Note that the user's arguments are also passed to your plugin's C<import()> +function as a list, eg: + + sub import { + my ($class, @args) = @_; + # @args will contain ( 'foo', 'bar', 'baz' ) + ... + } + +This is for backwards compatibility, and may be deprecated in the future. + +=head2 Sample Plugin + +Here's a sample plugin, for your reference: + + package App::Prove::Plugin::Foo; + + # Sample plugin, try running with: + # prove -PFoo=bar -r -j3 + # prove -PFoo -Q + # prove -PFoo=bar,My::Formatter + + use strict; + use warnings; + + sub load { + my ($class, $p) = @_; + my @args = @{ $p->{args} }; + my $app = $p->{app_prove}; + + print "loading plugin: $class, args: ", join(', ', @args ), "\n"; + + # turn on verbosity + $app->verbose( 1 ); + + # set the formatter? + $app->formatter( $args[1] ) if @args > 1; + + # print some of App::Prove's state: + for my $attr (qw( jobs quiet really_quiet recurse verbose )) { + my $val = $app->$attr; + $val = 'undef' unless defined( $val ); + print "$attr: $val\n"; + } + + return 1; + } + + 1; + +=head1 SEE ALSO + +L<prove>, L<TAP::Harness> + +=cut diff --git a/ext/Test-Harness/lib/App/Prove/State.pm b/ext/Test-Harness/lib/App/Prove/State.pm index 2b284d2074..6eef184a62 100644 --- a/ext/Test-Harness/lib/App/Prove/State.pm +++ b/ext/Test-Harness/lib/App/Prove/State.pm @@ -12,7 +12,10 @@ use TAP::Parser::YAMLish::Reader (); use TAP::Parser::YAMLish::Writer (); use TAP::Base; -@ISA = qw( TAP::Base ); +BEGIN { + @ISA = qw( TAP::Base ); + __PACKAGE__->mk_methods('result_class'); +} use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); use constant NEED_GLOB => IS_WIN32; @@ -23,11 +26,11 @@ App::Prove::State - State storage for the C<prove> command. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -48,6 +51,24 @@ and the operations that may be performed on it. =head3 C<new> +Accepts a hashref with the following key/value pairs: + +=over 4 + +=item * C<store> + +The filename of the data store holding the data that App::Prove::State reads. + +=item * C<extension> (optional) + +The test name extension. Defaults to C<.t>. + +=item * C<result_class> (optional) + +The name of the C<result_class>. Defaults to C<App::Prove::State::Result>. + +=back + =cut # override TAP::Base::new: @@ -56,17 +77,19 @@ sub new { my %args = %{ shift || {} }; my $self = bless { - _ => $class->result_class->new( - { tests => {}, - generation => 1, - } - ), select => [], seq => 1, store => delete $args{store}, - extension => delete $args{extension} || '.t', + extension => ( delete $args{extension} || '.t' ), + result_class => + ( delete $args{result_class} || 'App::Prove::State::Result' ), }, $class; + $self->{_} = $self->result_class->new( + { tests => {}, + generation => 1, + } + ); my $store = $self->{store}; $self->load($store) if defined $store && -f $store; @@ -76,16 +99,12 @@ sub new { =head2 C<result_class> -Returns the name of the class used for tracking test results. This class -should either subclass from C<App::Prove::State::Result> or provide an +Getter/setter for the name of the class used for tracking test results. This +class should either subclass from C<App::Prove::State::Result> or provide an identical interface. =cut -sub result_class { - return 'App::Prove::State::Result'; -} - =head2 C<extension> Get or set the extension files must have in order to be considered @@ -107,7 +126,7 @@ Get the results of the last test run. Returns a C<result_class()> instance. sub results { my $self = shift; - $self->{_} || $self->result_class->new + $self->{_} || $self->result_class->new; } =head2 C<commit> @@ -118,8 +137,8 @@ Save the test results. Should be called after all tests have run. sub commit { my $self = shift; - if ( $self->{should_save} && defined( my $store = $self->{store} ) ) { - $self->save($store); + if ( $self->{should_save} ) { + $self->save; } } @@ -373,15 +392,6 @@ Store the results of a test. =cut -sub observe_test { - my ( $self, $test, $parser ) = @_; - $self->_record_test( - $test->[0], - scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ), - scalar( $parser->todo ), $parser->start_time, $parser->end_time, - ); -} - # Store: # last fail time # last pass time @@ -391,10 +401,18 @@ sub observe_test { # total failures # total passes # state generation +# parser + +sub observe_test { -sub _record_test { - my ( $self, $name, $fail, $todo, $start_time, $end_time ) = @_; - my $test = $self->results->test($name); + my ( $self, $test_info, $parser ) = @_; + my $name = $test_info->[0]; + my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 ); + my $todo = scalar( $parser->todo ); + my $start_time = $parser->start_time; + my $end_time = $parser->end_time, + + my $test = $self->results->test($name); $test->sequence( $self->{seq}++ ); $test->generation( $self->results->generation ); @@ -404,6 +422,8 @@ sub _record_test { $test->num_todo($todo); $test->elapsed( $end_time - $start_time ); + $test->parser($parser); + if ($fail) { $test->total_failures( $test->total_failures + 1 ); $test->last_fail_time($end_time); @@ -421,13 +441,14 @@ Write the state to a file. =cut sub save { - my ( $self, $name ) = @_; + my ($self) = @_; + my $store = $self->{store} or return; $self->results->last_run_time( $self->get_time ); my $writer = TAP::Parser::YAMLish::Writer->new; local *FH; - open FH, ">$name" or croak "Can't write $name ($!)"; + open FH, ">$store" or croak "Can't write $store ($!)"; $writer->write( $self->results->raw, \*FH ); close FH; } diff --git a/ext/Test-Harness/lib/App/Prove/State/Result.pm b/ext/Test-Harness/lib/App/Prove/State/Result.pm index 37337ea258..a087da4d72 100644 --- a/ext/Test-Harness/lib/App/Prove/State/Result.pm +++ b/ext/Test-Harness/lib/App/Prove/State/Result.pm @@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -63,10 +63,11 @@ sub _initialize { my ( $self, $tests ) = @_; my %tests; while ( my ( $name, $test ) = each %$tests ) { - $tests{$name} = $self->test_class->new({ - %$test, - name => $name - }); + $tests{$name} = $self->test_class->new( + { %$test, + name => $name + } + ); } $self->tests( \%tests ); return $self; @@ -170,7 +171,7 @@ sub test { return $test; } else { - my $test = $self->test_class->new({name => $name}); + my $test = $self->test_class->new( { name => $name } ); $self->{tests}->{$name} = $test; return $test; } diff --git a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm index 50e209614f..4744086e9e 100644 --- a/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm +++ b/ext/Test-Harness/lib/App/Prove/State/Result/Test.pm @@ -10,11 +10,11 @@ App::Prove::State::Result::Test - Individual test results. =head1 VERSION -Version 3.14 +Version 3.16 =cut -$VERSION = '3.14'; +$VERSION = '3.16'; =head1 DESCRIPTION @@ -42,6 +42,7 @@ my %methods = ( seq => { method => 'sequence', default => 1 }, total_passes => { method => 'total_passes', default => 0 }, total_failures => { method => 'total_failures', default => 0 }, + parser => { method => 'parser' }, ); while ( my ( $key, $description ) = each %methods ) { @@ -132,14 +133,20 @@ The number of times the test has passed. The number of times the test has failed. +=head3 C<parser> + +The underlying parser object. This is useful if you need the full +information for the test program. + =cut sub raw { my $self = shift; my %raw = %$self; - # this is backwards-compatibility hack and is not gauranteed. + # this is backwards-compatibility hack and is not guaranteed. delete $raw{name}; + delete $raw{parser}; return \%raw; } |