=head1 VERSION
-Version 1.15
+Version 1.19
=cut
-our $VERSION = '1.15';
+our $VERSION = '1.19';
=head1 SYNOPSIS
Specify the maximum stack depth studied when valgrind encounters an error.
Raising this number improves granularity.
-Ignored if you supply your own custom C<tool>, otherwise defaults to C<12>.
+Ignored if you supply your own custom C<tool>, otherwise defaults to C<24> (the maximum allowed by C<valgrind>).
=item *
=item *
+C<< allow_no_supp => $bool >>
+
+If true, force running the analysis even if the suppression files do not refer to any C<perl>-related symbol.
+
+Defaults to false.
+
+=item *
+
C<< extra_supps => \@files >>
Also use suppressions from C<@files> besides C<perl>'s.
=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')) {
+ my $callers = delete $args{callers} || 24;
+ $callers = 24 if $callers <= 0;
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 => $callers,
+ );
+ };
+ unless ($tool) {
+ my ($err, $skippable) = $filter_errors{tool}->($@);
+ _croak($err) unless $skippable;
+ return _default_abort($err);
+ }
}
require Test::Valgrind::Session;
my $sess = eval {
Test::Valgrind::Session->new(
min_version => $tool->requires_version,
- map { $_ => delete $args{$_} } qw<regen_def_supp no_def_supp extra_supps>
+ map { $_ => delete $args{$_} } qw<
+ regen_def_supp
+ no_def_supp
+ allow_no_supp
+ extra_supps
+ >
);
};
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) {
=head1 DEPENDENCIES
-L<XML::Twig>, L<
version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
+L<XML::Twig>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
=head1 SEE ALSO
=head1 COPYRIGHT & LICENSE
-Copyright 2008,2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
+Copyright 2008,2009,2010,2011,2013,2015,2016 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.
projects / perl / modules / Test-Valgrind.git / blobdiff