Gensupp.PL

   1 use strict;
   2 use warnings;
   3
   4 my ($sf) = @ARGV;
   5 exit 1 unless defined $sf;
   6
   7 my $file = './gen.pl';
   8
   9 pipe my $rdr, my $wtr or die "pipe(\$rdr, \$wtr): $!";
  10 my $pid = fork;
  11 if (!defined $pid) {
  12  die "fork(): $!";
  13 } elsif ($pid == 0) {
  14  close $rdr or die "close(\$rdr): $!";
  15  open STDERR, '>&', $wtr or die "open(STDERR, '>&', \$wtr): $!";
  16  exec $^X, '-Mlib=lib', $file;
  17 }
  18 close $wtr or die "close(\$rdr): $!";
  19
  20 my ($s, $in, @supps) = ('', 0);
  21 while (<$rdr>) {
  22  s/^\s*#\s//;
  23  next if /^==/;
  24  next if /valgrind/ and /\Q$file\E/;
  25  s/^\s*//;
  26  s/<[^>]+>//;
  27  s/\s*$//;
  28  next unless length;
  29  if ($_ eq '{') {
  30   $in = 1;
  31  } elsif ($_ eq '}') {
  32   push @supps, $s;
  33   $s  = '';
  34   $in = 0;
  35  } elsif ($in) {
  36   $s .= "$_\n";
  37  }
  38 }
  39 waitpid $pid, 0;
  40
  41 select STDERR;
  42
  43 my $a = @supps;
  44 print "Found $a suppressions\n";
  45
  46 my @extra;
  47 for (@supps) {
  48  if (/\bfun:(m|c|re)alloc\b/) {
  49   my $t = $1;
  50   my %call;
  51   if ($t eq 'm') { # malloc can also be called by calloc or realloc
  52    $call{$_} = 1 for qw/calloc realloc/;
  53   } elsif ($t eq 're') { # realloc can also call malloc or free
  54    $call{$_} = 0 for qw/malloc free/;
  55   } elsif ($t eq 'c') { # calloc can also call malloc
  56    $call{$_} = 0 for qw/malloc/;
  57   }
  58   my $c = $_;
  59   for (keys %call) {
  60    my $d = $c;
  61    $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
  62    # Remove one line for each line added or valgrind will hate us
  63    $d =~ s/\n(.+?)\s*$/\n/;
  64    push @extra, $d;
  65   }
  66  }
  67 }
  68 my $e = @extra;
  69 print "Generated $e extra suppressions\n";
  70
  71 my %dupes;
  72 @dupes{@supps, @extra} = ();
  73 @supps = keys %dupes;
  74 my $b = @supps;
  75 print "Removed " . (($a + $e) - $b) . " duplicates\n";
  76
  77 my ($name, $num) = ('perlTestValgrind', 0);
  78
  79 1 while unlink $sf;
  80
  81 open my $out, '>', $sf or die "$!";
  82 print $out "{\n$name" . (++$num) . "\n$_}\n" for @supps;
  83 close $out;