X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FSession.pm;h=22a9129ebf728058d62cca6b7d6688faa8c32dd4;hb=cea977523ce9c4be865b97a0813a5e14cce873f9;hp=f47e4759228e608a636756884a1584eb1ef9a0f3;hpb=60a9b6451a4c8abbda345cc99fa4fe1393a87299;p=perl%2Fmodules%2FTest-Valgrind.git diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index f47e475..22a9129 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.02 +Version 1.13 =cut -our $VERSION = '1.02'; +our $VERSION = '1.13'; =head1 DESCRIPTION @@ -22,19 +22,15 @@ 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 -use base qw/Test::Valgrind::Carp/; +use version (); -use Test::Valgrind::Report; +use base qw; =head1 METHODS @@ -80,11 +76,6 @@ Defaults to none. =cut -my $build_version = sub { - require version; - version->new($_[0]); -}; - sub new { my $class = shift; $class = ref($class) || $class; @@ -92,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 { @@ -105,7 +96,7 @@ sub new { $class->_croak('Empty valgrind candidates list') unless @paths; my $min_version = delete $args{min_version}; - defined and not ref and $_ = $build_version->($_) for $min_version; + defined and not ref and $_ = version->new($_) for $min_version; my ($valgrind, $version); for (@paths) { @@ -113,7 +104,7 @@ sub new { my $ver = qx/$_ --version/; if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) { if ($min_version) { - $version = $build_version->($1); + $version = version->new($1); next if $version < $min_version; } else { $version = $1; @@ -151,7 +142,7 @@ sub version { my ($self) = @_; my $version = $self->{version}; - $self->{version} = $version = $build_version->($version) unless ref $version; + $self->{version} = $version = version->new($version) unless ref $version; return $version; } @@ -162,7 +153,7 @@ Read-only accessor for the C option. =cut -eval "sub $_ { \$_[0]->{$_} }" for qw/valgrind no_def_supp/; +eval "sub $_ { \$_[0]->{$_} }" for qw; =head2 C @@ -186,7 +177,7 @@ sub run { my %args = @_; $self->start(%args); - my $guard = bless sub { $self->finish } => 'Test::Valgrind::Session::Guard'; + my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish }); $self->_run($args{command}); } @@ -201,7 +192,7 @@ sub _run { $self->command($cmd); - $self->report(Test::Valgrind::Report->new_diag( + $self->report($self->report_class->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); @@ -210,27 +201,28 @@ 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" + )); + } + for ($self->suppressions) { + next unless -e $_; + $self->report($self->report_class->new_diag("Using suppression file $_")); + push @supp_args, "--suppressions=$_"; } - push @supp_args, '--suppressions=' . $_ for $self->suppressions; } pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!"); @@ -251,13 +243,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: $!"); } @@ -270,7 +262,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; @@ -279,7 +271,9 @@ sub _run { return; } -sub Test::Valgrind::Session::Guard::DESTROY { $_[0]->() } +sub Test::Valgrind::Session::Guard::new { bless \($_[1]), $_[0] } + +sub Test::Valgrind::Session::Guard::DESTROY { ${$_[0]}->() } =head2 C @@ -289,6 +283,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. @@ -297,7 +295,7 @@ Read-only accessor for the C associated to the current run. my @members; BEGIN { - @members = qw/action tool command/; + @members = qw; for (@members) { eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }"; die if $@; @@ -312,9 +310,17 @@ Forwards to C<< ->action->do_suppressions >>. sub do_suppressions { $_[0]->action->do_suppressions } +=head2 C + +Calls C<< ->tool->parser_class >> with the current session object as the unique argument. + +=cut + +sub parser_class { $_[0]->tool->parser_class($_[0]) } + =head2 C -Calls C<< ->action->report_class >> with the current session object as the unique argument. +Calls C<< ->tool->report_class >> with the current session object as the unique argument. =cut @@ -382,7 +388,7 @@ sub start { my %args = @_; - for (@members) { + for (qw) { my $base = 'Test::Valgrind::' . ucfirst; my $value = $args{$_}; $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) @@ -390,9 +396,10 @@ sub start { $self->$_($args{$_}) } - delete @{$self}{qw/last_status exit_code/}; + delete @{$self}{qw}; $self->tool->start($self); + $self->parser($self->parser_class->new)->start($self); $self->action->start($self); return; @@ -406,6 +413,7 @@ Forwards to C<< ->action->abort >> after unshifting the session object to the ar sub abort { my $self = shift; + $self->action->abort($self, @_); } @@ -420,8 +428,10 @@ sub report { return unless defined $report; - $report = $self->command->filter($self, $report); - return unless defined $report; + for my $handler (qw) { + $report = $self->$handler->filter($self, $report); + return unless defined $report; + } $self->action->report($self, $report); } @@ -437,7 +447,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); @@ -458,7 +470,7 @@ sub status { $_[0]->{last_status} } =head1 SEE ALSO -L, L, L, L. +L, L, L, L, L. L, L. @@ -481,7 +493,7 @@ You can find documentation for this module with the perldoc command. =head1 COPYRIGHT & LICENSE -Copyright 2009 Vincent Pit, all rights reserved. +Copyright 2009,2010,2011 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.