From: Vincent Pit Date: Wed, 11 Nov 2015 15:46:32 +0000 (-0200) Subject: Revamp test skipping logic X-Git-Tag: v1.16~8 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Valgrind.git;a=commitdiff_plain;h=5b7da288da2757d62ecaa3de0c40ea876ef9be2b Revamp test skipping logic The Test::Valgrind tests should now be skipped more reliably when no good valgrind setup is available. VPIT::TestHelpers is now bundled. --- diff --git a/MANIFEST b/MANIFEST index e91a24f..0573979 100644 --- a/MANIFEST +++ b/MANIFEST @@ -35,9 +35,11 @@ t/00-load.t t/10-good.t t/12-good-run-exception.t t/20-bad.t +t/30-skip.t t/70-session.t t/80-suppressions.t t/81-suppressions-demangle.t t/lib/Test/Valgrind/FakeValgrind.pm t/lib/Test/Valgrind/Test/Action.pm +t/lib/VPIT/TestHelpers.pm t/supp/no_perl diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm index ed3a197..8da4a0a 100644 --- a/lib/Test/Valgrind.pm +++ b/lib/Test/Valgrind.pm @@ -134,6 +134,61 @@ Defaults to empty. =cut +sub _croak { + require Carp; + Carp::croak(@_); +} + +my %skippable_errors = ( + session => [ + 'Empty valgrind candidates list', + 'No appropriate valgrind executable could be found', + ], + action => [ ], + tool => [ ], + command => [ ], + run => [ + 'No compatible suppressions available', + ], +); + +my %filter_errors; + +for my $obj (keys %skippable_errors) { + my @errors = @{$skippable_errors{$obj} || []}; + if (@errors) { + my $rxp = join '|', @errors; + $rxp = qr/($rxp)\s+at.*/; + $filter_errors{$obj} = sub { + my ($err) = @_; + if ($err =~ /$rxp/) { + return ($1, 1); + } else { + return ($err, 0); + } + }; + } else { + $filter_errors{$obj} = sub { + return ($_[0], 0); + }; + } +} + +sub _default_abort { + my ($err) = @_; + + require Test::Builder; + my $tb = Test::Builder->new; + my $plan = $tb->has_plan; + if (defined $plan) { + $tb->BAIL_OUT($err); + return 255; + } else { + $tb->skip_all($err); + return 0; + } +} + sub analyse { shift; @@ -144,32 +199,21 @@ sub analyse { Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]); }; - my $cmd = delete $args{command}; - unless ($cmd->$instanceof('Test::Valgrind::Command')) { - require Test::Valgrind::Command; - $cmd = Test::Valgrind::Command->new( - command => $cmd || 'PerlScript', - file => delete $args{file}, - args => [ '-MTest::Valgrind=run,1' ], - ); - } - my $tool = delete $args{tool}; unless ($tool->$instanceof('Test::Valgrind::Tool')) { require Test::Valgrind::Tool; - $tool = Test::Valgrind::Tool->new( - tool => $tool || 'memcheck', - callers => delete $args{callers}, - ); - } - - my $action = delete $args{action}; - unless ($action->$instanceof('Test::Valgrind::Action')) { - require Test::Valgrind::Action; - $action = Test::Valgrind::Action->new( - action => $action || 'Test', - diag => delete $args{diag}, - ); + local $@; + $tool = eval { + Test::Valgrind::Tool->new( + tool => $tool || 'memcheck', + callers => delete $args{callers}, + ); + }; + unless ($tool) { + my ($err, $skippable) = $filter_errors{tool}->($@); + _croak($err) unless $skippable; + return _default_abort($err); + } } require Test::Valgrind::Session; @@ -180,22 +224,66 @@ sub analyse { ); }; unless ($sess) { - my $err = $@; - $err =~ s/^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/$1/; - $action->abort($sess, $err); - return $action->status($sess); + my ($err, $skippable) = $filter_errors{session}->($@); + _croak($err) unless $skippable; + return _default_abort($err); } - eval { - $sess->run( - command => $cmd, - tool => $tool, - action => $action, - ); - }; - if ($@) { - require Test::Valgrind::Report; - $action->report($sess, Test::Valgrind::Report->new_diag($@)); + my $action = delete $args{action}; + unless ($action->$instanceof('Test::Valgrind::Action')) { + require Test::Valgrind::Action; + local $@; + $action = eval { + Test::Valgrind::Action->new( + action => $action || 'Test', + diag => delete $args{diag}, + ); + }; + unless ($action) { + my ($err, $skippable) = $filter_errors{action}->($@); + _croak($err) unless $skippable; + return _default_abort($err); + } + } + + my $cmd = delete $args{command}; + unless ($cmd->$instanceof('Test::Valgrind::Command')) { + require Test::Valgrind::Command; + local $@; + $cmd = eval { + Test::Valgrind::Command->new( + command => $cmd || 'PerlScript', + file => delete $args{file}, + args => [ '-MTest::Valgrind=run,1' ], + ); + }; + unless ($cmd) { + my ($err, $skippable) = $filter_errors{command}->($@); + _croak($err) unless $skippable; + $action->abort($sess, $err); + return $action->status($sess); + } + } + + { + local $@; + eval { + $sess->run( + command => $cmd, + tool => $tool, + action => $action, + ); + 1 + } or do { + my ($err, $skippable) = $filter_errors{run}->($@); + if ($skippable) { + $action->abort($sess, $err); + return $action->status($sess); + } else { + require Test::Valgrind::Report; + $action->report($sess, Test::Valgrind::Report->new_diag($@)); + } + } } my $status = $sess->status; @@ -236,10 +324,7 @@ sub import { my $class = shift; $class = ref($class) || $class; - if (@_ % 2) { - require Carp; - Carp::croak('Optional arguments must be passed as key => value pairs'); - } + _croak('Optional arguments must be passed as key => value pairs') if @_ % 2; my %args = @_; if (defined delete $args{run} or $run) { diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index 51fd0bd..da71b78 100644 --- a/lib/Test/Valgrind/Session.pm +++ b/lib/Test/Valgrind/Session.pm @@ -230,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 }); - - $self->_run($args{command}); -} + my ($self, %args) = @_; -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 )); @@ -303,6 +302,9 @@ sub _run { @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; @@ -338,7 +340,7 @@ 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): $!"); @@ -461,11 +463,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. @@ -475,16 +473,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); diff --git a/lib/Test/Valgrind/Tool/memcheck.pm b/lib/Test/Valgrind/Tool/memcheck.pm index 5adf933..e3932ef 100644 --- a/lib/Test/Valgrind/Tool/memcheck.pm +++ b/lib/Test/Valgrind/Tool/memcheck.pm @@ -116,8 +116,12 @@ This tool emits C object reports in anal sub report_class { my ($self, $session) = @_; - $session->do_suppressions ? 'Test::Valgrind::Report::Suppressions' - : 'Test::Valgrind::Tool::memcheck::Report' + if ($session->do_suppressions) { + require Test::Valgrind::Parser::Suppressions::Text; + return 'Test::Valgrind::Report::Suppressions'; + } else { + return 'Test::Valgrind::Tool::memcheck::Report'; + } } sub args { diff --git a/t/30-skip.t b/t/30-skip.t new file mode 100644 index 0000000..f693a29 --- /dev/null +++ b/t/30-skip.t @@ -0,0 +1,51 @@ +#!perl + +use strict; +use warnings; + +use lib 't/lib'; +use VPIT::TestHelpers 'capture'; + +use Test::More tests => 3; + +use Test::Valgrind::FakeValgrind; + +SKIP: { + my ($stat, $out, $err) = capture_perl 'BEGIN { delete $ENV{PATH} } use Test::Valgrind; 1'; + skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; + like $out, qr/^1..0 # SKIP Empty valgrind candidates list/, + 'correctly skip when no valgrind is available'; +} + +SKIP: { + skip 'Only on linux or darwin' => 1 unless $^O eq 'linux' or $^O eq 'darwin'; + + my $old_vg = Test::Valgrind::FakeValgrind->new( + exe_name => 'valgrind', + version => '3.0.0', + ); + skip $old_vg => 1 unless ref $old_vg; + my $tmp_dir = $old_vg->dir; + + my ($stat, $out, $err) = capture_perl "BEGIN { \$ENV{PATH} = q[$tmp_dir] } use Test::Valgrind; 1"; + skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; + like $out, qr/^1..0 # SKIP No appropriate valgrind executable could be found/, + 'correctly skip when no good valgrind was found'; +} + +SKIP: { + skip 'Only on linux or darwin' => 1 unless $^O eq 'linux' or $^O eq 'darwin'; + + my $new_vg = Test::Valgrind::FakeValgrind->new( + exe_name => 'valgrind', + version => '3.4.0', + ); + skip $new_vg => 1 unless ref $new_vg; + my $tmp_dir = $new_vg->dir; + + my ($stat, $out, $err) = capture_perl "BEGIN { \$ENV{PATH} = q[$tmp_dir] } use Test::Valgrind no_def_supp => 1, extra_supps => [ q[t/supp/no_perl] ]; 1"; + skip CAPTURE_PERL_FAILED($out) => 1 unless defined $stat; + like $out, qr/^1..0 # SKIP No compatible suppressions available/, + 'correctly skip when no compatible suppressions were available'; +} +