use strict; use warnings; my ($sf) = @ARGV; exit 1 unless defined $sf; my $file = './gen.pl'; pipe my $rdr, my $wtr or die "pipe(\$rdr, \$wtr): $!"; my $pid = fork; if (!defined $pid) { die "fork(): $!"; } elsif ($pid == 0) { close $rdr or die "close(\$rdr): $!"; open STDERR, '>&', $wtr or die "open(STDERR, '>&', \$wtr): $!"; exec $^X, '-Mlib=lib', $file; } close $wtr or die "close(\$rdr): $!"; my ($s, $in, @supps) = ('', 0); while (<$rdr>) { s/^\s*#\s//; next if /^==/; next if /valgrind/ and /\Q$file\E/; 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 "{\n$name" . (++$num) . "\n$_}\n" for @supps; close $out;