X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FSession.pm;h=b0069df7fdf1c2534218f2b644d42a75a8add912;hb=39af0cb1411f565d286cd656a7a0bdd3d3ba07fb;hp=0e2a004e480c7b807960848615505fa37203d6f6;hpb=77d53e292f2fdac4991d1d6c140f1edd79ff3afa;p=perl%2Fmodules%2FTest-Valgrind.git diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index 0e2a004..b0069df 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.13 +Version 1.15 =cut -our $VERSION = '1.13'; +our $VERSION = '1.15'; =head1 DESCRIPTION @@ -37,12 +37,14 @@ use base qw; =head2 C my $tvs = Test::Valgrind::Session->new( - search_dirs => \@search_dirs, - valgrind => $valgrind, # One candidate - valgrind => \@valgrind, # Several candidates - min_version => $min_version, - no_def_supp => $no_def_supp, - extra_supps => \@extra_supps, + search_dirs => \@search_dirs, + valgrind => $valgrind, # One candidate + valgrind => \@valgrind, # Several candidates + min_version => $min_version, + regen_def_supp => $regen_def_supp, + no_def_supp => $no_def_supp, + allow_no_supp => $allow_no_supp, + extra_supps => \@extra_supps, ); The package constructor, which takes several options : @@ -71,7 +73,19 @@ Defaults to none. =item * -If C<$no_def_supp> is false, C won't read the default suppression file associated with the tool and the command. +If C<$regen_def_supp> is true, the default suppression file associated with the tool and the command will be forcefully regenerated. + +Defaults to false. + +=item * + +If C<$no_def_supp> is true, C won't read the default suppression file associated with the tool and the command. + +Defaults to false. + +=item * + +If C<$allow_no_supp> is true, the command will always be run into C even if no appropriate suppression file is available. Defaults to false. @@ -130,10 +144,12 @@ sub new { @$extra_supps = grep { defined && -f $_ && -r _ } @$extra_supps; bless { - valgrind => $valgrind, - version => $version, - no_def_supp => delete($args{no_def_supp}), - extra_supps => $extra_supps, + valgrind => $valgrind, + version => $version, + regen_def_supp => delete($args{regen_def_supp}), + no_def_supp => delete($args{no_def_supp}), + allow_no_supp => delete($args{allow_no_supp}), + extra_supps => $extra_supps, }, $class; } @@ -160,15 +176,34 @@ sub version { return $version; } +=head2 C + + my $regen_def_supp = $tvs->regen_def_supp; + +Read-only accessor for the C option. + +=cut + =head2 C my $no_def_supp = $tvs->no_def_supp; Read-only accessor for the C option. +=head2 C + + my $allow_no_supp = $tvs->allow_no_supp; + +Read-only accessor for the C option. + =cut -eval "sub $_ { \$_[0]->{$_} }" for qw; +eval "sub $_ { \$_[0]->{$_} }" for qw< + valgrind + regen_def_supp + no_def_supp + allow_no_supp +>; =head2 C @@ -195,26 +230,25 @@ If the command is a L object, the action and =cut sub run { - my $self = shift; - - my %args = @_; - - $self->start(%args); - my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish }); + my ($self, %args) = @_; - $self->_run($args{command}); -} - -sub _run { - my ($self, $cmd) = @_; + for (qw) { + my $base = 'Test::Valgrind::' . ucfirst; + my $value = $args{$_}; + $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) + and $value->isa($base); + $self->$_($args{$_}) + } + my $cmd = $self->command; if ($cmd->isa('Test::Valgrind::Command::Aggregate')) { - $self->_run($_) for $cmd->commands; + for my $subcmd ($cmd->commands) { + $args{command} = $subcmd; + $self->run(%args); + } return; } - $self->command($cmd); - $self->report($self->report_class->new_diag( 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind )); @@ -224,30 +258,53 @@ sub _run { my @supp_args; if ($self->do_suppressions) { push @supp_args, '--gen-suppressions=all'; - } elsif (not $self->no_def_supp) { - my $def_supp = $self->def_supp_file; - if (defined $def_supp and not -e $def_supp) { + } else { + if (!$self->no_def_supp) { + my $def_supp = $self->def_supp_file; + my $forced; + if ($self->regen_def_supp and -e $def_supp) { + 1 while unlink $def_supp; + $forced = 1; + } + if (defined $def_supp and not -e $def_supp) { + $self->report($self->report_class->new_diag( + 'Generating suppressions' . ($forced ? ' (forced)' : '') . '...' + )); + 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" + )); + } + } + my @supp_files = grep { + -e $_ and $self->command->check_suppressions_file($_) + } $self->suppressions; + if (@supp_files > 1) { + my $files_list = join "\n", map " $_", @supp_files; $self->report($self->report_class->new_diag( - "Generating suppressions..." + "Using suppressions from:\n$files_list" )); - 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; + } elsif (@supp_files) { $self->report($self->report_class->new_diag( - "Suppressions for this perl stored in $def_supp" + "Using suppressions from $supp_files[0]" )); + } elsif ($self->allow_no_supp) { + $self->report($self->report_class->new_diag("No suppressions used")); + } else { + $self->_croak("No compatible suppressions available"); } - for ($self->suppressions) { - next unless -e $_; - $self->report($self->report_class->new_diag("Using suppression file $_")); - push @supp_args, "--suppressions=$_"; - } + @supp_args = map "--suppressions=$_", @supp_files; } + my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish }); + $self->start; + pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!"); { my $oldfh = select $vrdr; @@ -259,7 +316,10 @@ sub _run { $self->_croak("fork(): $!") unless defined $pid; if ($pid == 0) { - eval 'setpgrp 0, 0'; + { + local $@; + eval { setpgrp(0, 0) }; + } close $vrdr or $self->_croak("close(\$vrdr): $!"); fcntl $vwtr, Fcntl::F_SETFD(), 0 or $self->_croak("fcntl(\$vwtr, F_SETFD, 0): $!"); @@ -280,12 +340,14 @@ sub _run { local $SIG{INT} = sub { kill -(POSIX::SIGKILL()) => $pid; waitpid $pid, 0; - die 'interrupted'; + die 'valgrind analysis was interrupted'; }; close $vwtr or $self->_croak("close(\$vwtr): $!"); - $self->parser->parse($self, $vrdr); + my $aborted = $self->parser->parse($self, $vrdr); + + kill -(POSIX::SIGKILL()) => $pid if $aborted; $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255; @@ -403,11 +465,7 @@ sub suppressions { =head2 C - $tvs->start( - action => $action, - tool => $tool, - command => $command, - ); + $tvs->start; Starts the action and tool associated to the current run. It's automatically called at the beginning of L. @@ -417,16 +475,6 @@ It's automatically called at the beginning of L. sub start { my $self = shift; - my %args = @_; - - for (qw) { - my $base = 'Test::Valgrind::' . ucfirst; - my $value = $args{$_}; - $self->_croak("Invalid $_") unless Scalar::Util::blessed($value) - and $value->isa($base); - $self->$_($args{$_}) - } - delete @{$self}{qw}; $self->tool->start($self); @@ -532,7 +580,7 @@ You can find documentation for this module with the perldoc command. =head1 COPYRIGHT & LICENSE -Copyright 2009,2010,2011,2013 Vincent Pit, all rights reserved. +Copyright 2009,2010,2011,2013,2015 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.