From: Vincent Pit Date: Mon, 25 Aug 2008 16:46:46 +0000 (+0200) Subject: Generate extra suppressions and remove duplicated ones X-Git-Tag: v0.05~7 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=db13282b745dfe28c52272c092ff4b9be81fc487;p=perl%2Fmodules%2FTest-Valgrind.git Generate extra suppressions and remove duplicated ones --- diff --git a/Gensupp.PL b/Gensupp.PL index 024efee..7fb875c 100755 --- a/Gensupp.PL +++ b/Gensupp.PL @@ -17,17 +17,67 @@ if (!defined $pid) { } close $wtr or die "close(\$rdr): $!"; -my ($supp, $name, $num) = ('', 'perlTestValgrind', 0); +my ($s, $in, @supps) = ('', 0); while (<$rdr>) { s/^\s*#\s//; next if /^==/; next if /valgrind/ and /\Q$file\E/; - s/<[^>]+>/$name . ++$num/e; - $supp .= $_; + s/^\s*//; + s/<[^>]+>//; + s/\s*$//; + next unless length; + if ($_ eq '{') { + $in = 1; + } elsif ($_ eq '}') { + push @supps, $s; + $s = ''; + $in = 0; + } elsif ($in) { + $s .= "$_\n"; + } } waitpid $pid, 0; +select STDERR; + +my $a = @supps; +print "Found $a suppressions\n"; + +my @extra; +for (@supps) { + if (/\bfun:(m|c|re)alloc\b/) { + my $t = $1; + my %call; + if ($t eq 'm') { # malloc can also be called by calloc or realloc + $call{$_} = 1 for qw/calloc realloc/; + } elsif ($t eq 're') { # realloc can also call malloc or free + $call{$_} = 0 for qw/malloc free/; + } elsif ($t eq 'c') { # calloc can also call malloc + $call{$_} = 0 for qw/malloc/; + } + my $c = $_; + for (keys %call) { + my $d = $c; + $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e; + # Remove one line for each line added or valgrind will hate us + $d =~ s/\n(.+?)\s*$/\n/; + push @extra, $d; + } + } +} +my $e = @extra; +print "Generated $e extra suppressions\n"; + +my %dupes; +@dupes{@supps, @extra} = (); +@supps = keys %dupes; +my $b = @supps; +print "Removed " . (($a + $e) - $b) . " duplicates\n"; + +my ($name, $num) = ('perlTestValgrind', 0); + 1 while unlink $sf; + open my $out, '>', $sf or die "$!"; -print $out $supp; +print $out "{\n$name" . (++$num) . "\n$_}\n" for @supps; close $out;