X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind.pm;h=43c045886e0203196a2f1e05d9b934aa83b03cc8;hb=f2071d95aaaa4817e91cc33530deedc8d701d44d;hp=ed3a1976bedd63d99446b4d1a3fc35c61bc64893;hpb=63f17cfcf624bc6764d32a7e674baf6329fd2d4a;p=perl%2Fmodules%2FTest-Valgrind.git diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm index ed3a197..43c0458 100644 --- a/lib/Test/Valgrind.pm +++ b/lib/Test/Valgrind.pm @@ -9,11 +9,11 @@ Test::Valgrind - Generate suppressions, analyse and test any command with valgri =head1 VERSION -Version 1.15 +Version 1.19 =cut -our $VERSION = '1.15'; +our $VERSION = '1.19'; =head1 SYNOPSIS @@ -96,7 +96,7 @@ C<< callers => $number >> Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. -Ignored if you supply your own custom C, otherwise defaults to C<12>. +Ignored if you supply your own custom C, otherwise defaults to C<24> (the maximum allowed by C). =item * @@ -124,6 +124,14 @@ Defaults to false. =item * +C<< allow_no_supp => $bool >> + +If true, force running the analysis even if the suppression files do not refer to any C-related symbol. + +Defaults to false. + +=item * + C<< extra_supps => \@files >> Also use suppressions from C<@files> besides C's. @@ -134,6 +142,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,58 +207,98 @@ 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')) { + 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 + 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; @@ -236,10 +339,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) { @@ -338,7 +438,7 @@ What your tests output to C and C is eaten unless you pass the C =head1 DEPENDENCIES -L, L, L, L, L. +L, L, L, L. =head1 SEE ALSO @@ -381,7 +481,7 @@ All you people that showed interest in this module, which motivated me into comp =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.