From: Vincent Pit Date: Mon, 20 Apr 2009 09:57:44 +0000 (+0200) Subject: Add a new T::V::Command::Aggregate that aggregates several commands together X-Git-Tag: v1.02~9 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=0e79c45af8d5eabe900280cc0e5467936467dee9;p=perl%2Fmodules%2FTest-Valgrind.git Add a new T::V::Command::Aggregate that aggregates several commands together --- diff --git a/MANIFEST b/MANIFEST index 785365d..8c37660 100644 --- a/MANIFEST +++ b/MANIFEST @@ -11,6 +11,7 @@ lib/Test/Valgrind/Action/Suppressions.pm lib/Test/Valgrind/Action/Test.pm lib/Test/Valgrind/Carp.pm lib/Test/Valgrind/Command.pm +lib/Test/Valgrind/Command/Aggregate.pm lib/Test/Valgrind/Command/Perl.pm lib/Test/Valgrind/Command/PerlScript.pm lib/Test/Valgrind/Report.pm diff --git a/lib/Test/Valgrind/Command.pm b/lib/Test/Valgrind/Command.pm index 0b491ba..eb5a347 100644 --- a/lib/Test/Valgrind/Command.pm +++ b/lib/Test/Valgrind/Command.pm @@ -50,7 +50,7 @@ sub new { } my $args = delete $args{args}; - $class->_croak('Invalid argument list') unless $args and ref $args eq 'ARRAY'; + $class->_croak('Invalid argument list') if $args and ref $args ne 'ARRAY'; bless { args => $args, diff --git a/lib/Test/Valgrind/Command/Aggregate.pm b/lib/Test/Valgrind/Command/Aggregate.pm new file mode 100644 index 0000000..3b985da --- /dev/null +++ b/lib/Test/Valgrind/Command/Aggregate.pm @@ -0,0 +1,96 @@ +package Test::Valgrind::Command::Aggregate; + +use strict; +use warnings; + +=head1 NAME + +Test::Valgrind::Command::Aggregate - A Test::Valgrind command that aggregates several other commands. + +=head1 VERSION + +Version 1.01 + +=cut + +our $VERSION = '1.01'; + +=head1 DESCRIPTION + +=cut + +use Scalar::Util (); + +use base qw/Test::Valgrind::Command Test::Valgrind::Carp/; + +=head1 METHODS + +This class inherits L. + +=head2 C<< new commands => \@commands, ... >> + +=cut + +my $all_cmds = sub { + for (@{$_[0]}) { + return 0 unless Scalar::Util::blessed($_) + and $_->isa('Test::Valgrind::Command'); + } + return 1; +}; + +sub new { + my $class = shift; + $class = ref($class) || $class; + + my %args = @_; + + my $cmds = delete $args{commands}; + $class->_croak('Invalid commands list') + unless $cmds and ref $cmds eq 'ARRAY' and $all_cmds->($cmds); + + my $self = bless $class->SUPER::new(), $class; + + $self->{commands} = [ @$cmds ]; + + $self; +} + +=head2 C + +Read-only accessor for the C option. + +=cut + +sub commands { @{$_[0]->{commands} || []} } + +=head1 SEE ALSO + +L, L. + +=head1 AUTHOR + +Vincent Pit, C<< >>, L. + +You can contact me by mail or on C (vincent). + +=head1 BUGS + +Please report any bugs or feature requests to C, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc Test::Valgrind::Command::Aggregate + +=head1 COPYRIGHT & LICENSE + +Copyright 2009 Vincent Pit, all rights reserved. + +This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. + +=cut + +1; # End of Test::Valgrind::Command::Aggregate diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index d65ca9e..3174bde 100644 --- a/lib/Test/Valgrind/Session.pm +++ b/lib/Test/Valgrind/Session.pm @@ -176,14 +176,31 @@ sub extra_supps { @{$_[0]->{extra_supps} || []} } Runs the command C<$command> through C with the tool C<$tool>, which will report to the action C<$action>. +If the command is a L object, the action and the tool will be initialized once before running all the aggregated commands. + =cut sub run { my $self = shift; - $self->start(@_); + my %args = @_; + + $self->start(%args); my $guard = bless sub { $self->finish } => 'Test::Valgrind::Session::Guard'; + $self->_run($args{command}); +} + +sub _run { + my ($self, $cmd) = @_; + + if ($cmd->isa('Test::Valgrind::Command::Aggregate')) { + $self->_run($_) for $cmd->commands; + return; + } + + $self->command($cmd); + $self->report(Test::Valgrind::Report->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); diff --git a/t/92-pod-coverage.t b/t/92-pod-coverage.t index dcfcec8..e78b413 100644 --- a/t/92-pod-coverage.t +++ b/t/92-pod-coverage.t @@ -18,7 +18,7 @@ plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@ my $trustparents = { coverage_class => 'Pod::Coverage::CountParents' }; -plan tests => 15; +plan tests => 16; pod_coverage_ok('Test::Valgrind'); @@ -30,6 +30,7 @@ pod_coverage_ok('Test::Valgrind::Action::Test', $trustparents); pod_coverage_ok('Test::Valgrind::Carp'); pod_coverage_ok('Test::Valgrind::Command'); +pod_coverage_ok('Test::Valgrind::Command::Aggregate', $trustparents); pod_coverage_ok('Test::Valgrind::Command::Perl', $trustparents); pod_coverage_ok('Test::Valgrind::Command::PerlScript', $trustparents);