=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;
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;
);
};
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;
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) {
=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<action tool command>) {
+ 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
));
@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;
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): $!");
=head2 C<start>
- $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</run>.
sub start {
my $self = shift;
- my %args = @_;
-
- for (qw<action tool command>) {
- 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<last_status exit_code>};
$self->tool->start($self);
--- /dev/null
+#!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';
+}
+
projects / perl / modules / Test-Valgrind.git / commitdiff