X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FSession.pm;h=4b731fca2b769e137bdd9eea6b3e611dfbce1fc4;hb=08860dad1f820cce06758ec4add9353a4dbc8175;hp=6c09793a91e20c08e28c973613f0f16794a3e88c;hpb=b41c498738a3a4ccb8742883a42e6ea5addb1afd;p=perl%2Fmodules%2FTest-Valgrind.git diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index 6c09793..4b731fc 100644 --- a/lib/Test/Valgrind/Session.pm +++ b/lib/Test/Valgrind/Session.pm @@ -9,11 +9,11 @@ Test::Valgrind::Session - Test::Valgrind session object. =head1 VERSION -Version 1.00 +Version 1.10 =cut -our $VERSION = '1.00'; +our $VERSION = '1.10'; =head1 DESCRIPTION @@ -22,22 +22,16 @@ It also acts as a dispatcher between the different components. =cut -# All these modules are required at configure time. +use File::Spec (); +use Scalar::Util (); -BEGIN { - require File::Spec; - require Scalar::Util; - - require Fcntl; # F_SETFD - require POSIX; # SIGKILL +use Fcntl (); # F_SETFD +use POSIX (); # SIGKILL - require version; -} +use version (); use base qw/Test::Valgrind::Carp/; -use Test::Valgrind::Report; - =head1 METHODS =head2 C<< new search_dirs => \@search_dirs, valgrind => [ $valgrind | \@valgrind ], min_version => $min_version, no_def_supp => $no_def_supp, extra_supps => \@extra_supps >> @@ -89,7 +83,7 @@ sub new { my %args = @_; my @paths; - my $vg = delete $args{vg}; + my $vg = delete $args{valgrind}; if (defined $vg and not ref $vg) { @paths = ($vg); } else { @@ -109,8 +103,12 @@ sub new { next unless -x; my $ver = qx/$_ --version/; if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) { - $version = version->new($1); - next if $min_version and $version < $min_version; + if ($min_version) { + $version = version->new($1); + next if $version < $min_version; + } else { + $version = $1; + } $valgrind = $_; last; } @@ -138,13 +136,24 @@ The path to the selected C executable. The L object associated to the selected C. +=cut + +sub version { + my ($self) = @_; + + my $version = $self->{version}; + $self->{version} = $version = version->new($version) unless ref $version; + + return $version; +} + =head2 C Read-only accessor for the C option. =cut -eval "sub $_ { \$_[0]->{$_} }" for qw/valgrind version no_def_supp/; +eval "sub $_ { \$_[0]->{$_} }" for qw/valgrind no_def_supp/; =head2 C @@ -158,15 +167,32 @@ 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->report(Test::Valgrind::Report->new_diag( + $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($self->report_class->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); @@ -175,21 +201,22 @@ sub run { my @supp_args; if ($self->do_suppressions) { push @supp_args, '--gen-suppressions=all'; - } else { - my @supps; - if (not $self->no_def_supp) { - my $def_supp = $self->def_supp_file; - if (defined $def_supp and not -e $def_supp) { - $self->report(Test::Valgrind::Report->new_diag("Generating suppressions...")); - require Test::Valgrind::Suppressions; - Test::Valgrind::Suppressions->generate( - tool => $self->tool, - command => $self->command, - target => $def_supp, - ); - $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp; - $self->report(Test::Valgrind::Report->new_diag("Suppressions for this perl stored in $def_supp")); - } + } elsif (not $self->no_def_supp) { + my $def_supp = $self->def_supp_file; + if (defined $def_supp and not -e $def_supp) { + $self->report($self->report_class->new_diag( + "Generating suppressions..." + )); + require Test::Valgrind::Suppressions; + Test::Valgrind::Suppressions->generate( + tool => $self->tool, + command => $self->command, + target => $def_supp, + ); + $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp; + $self->report($self->report_class->new_diag( + "Suppressions for this perl stored in $def_supp" + )); } push @supp_args, '--suppressions=' . $_ for $self->suppressions; } @@ -212,13 +239,13 @@ sub run { my @args = ( $self->valgrind, - '--log-fd=' . fileno($vwtr), $self->tool->args($self), @supp_args, + $self->parser->args($self, $vwtr), $self->command->args($self), ); -# $self->report(Test::Valgrind::Report->new_diag("@args")); +# $self->report($self->report_class->new_diag("@args")); exec { $args[0] } @args or $self->_croak("exec @args: $!"); } @@ -231,7 +258,7 @@ sub run { close $vwtr or $self->_croak("close(\$vwtr): $!"); - $self->tool->parse($self, $vrdr); + $self->parser->parse($self, $vrdr); $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; @@ -250,6 +277,10 @@ Read-only accessor for the C associated to the current run. Read-only accessor for the C associated to the current run. +=head2 C + +Read-only accessor for the C associated to the current tool. + =head2 C Read-only accessor for the C associated to the current run. @@ -258,7 +289,7 @@ Read-only accessor for the C associated to the current run. my @members; BEGIN { - @members = qw/action tool command/; + @members = qw/action tool command parser/; for (@members) { eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"; die if $@; @@ -275,7 +306,7 @@ sub do_suppressions { $_[0]->action->do_suppressions } =head2 C -Calls C<< ->action->report_class >> with the current session object as the sole argument. +Calls C<< ->action->report_class >> with the current session object as the unique argument. =cut @@ -284,7 +315,8 @@ sub report_class { $_[0]->tool->report_class($_[0]) } =head2 C Returns an absolute path to the default suppression file associated to the current session. -C will be returned as soon as any of C<< ->tool->suppressions_tag >> or C<< ->tool->suppressions_tag >> are also C. + +C will be returned as soon as any of C<< ->command->suppressions_tag >> or C<< ->tool->suppressions_tag >> are also C. Otherwise, the file part of the name is builded by joining those two together, and the directory part is roughly F<< File::HomeDir->my_home / .perl / Test-Valgrind / suppressions / $VERSION >>. =cut @@ -342,7 +374,7 @@ sub start { my %args = @_; - for (@members) { + for (qw/action tool command/) { my $base = 'Test::Valgrind::' . ucfirst; my $value = $args{$_}; $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) @@ -353,6 +385,7 @@ sub start { delete @{$self}{qw/last_status exit_code/}; $self->tool->start($self); + $self->parser($self->tool->parser_class($self)->new)->start($self); $self->action->start($self); return; @@ -366,6 +399,7 @@ Forwards to C<< ->action->abort >> after unshifting the session object to the ar sub abort { my $self = shift; + $self->action->abort($self, @_); } @@ -376,8 +410,16 @@ Forwards to C<< ->action->report >> after unshifting the session object to the a =cut sub report { - my $self = shift; - $self->action->report($self, @_); + my ($self, $report) = @_; + + return unless defined $report; + + for my $handler (qw/tool command/) { + $report = $self->$handler->filter($self, $report); + return unless defined $report; + } + + $self->action->report($self, $report); } =head2 C @@ -391,7 +433,9 @@ sub finish { my ($self) = @_; my $action = $self->action; + $action->finish($self); + $self->parser->finish($self); $self->tool->finish($self); my $status = $action->status($self); @@ -412,7 +456,7 @@ sub status { $_[0]->{last_status} } =head1 SEE ALSO -L, L, L, L. +L, L, L, L, L. L, L.