Porting/valgrindpp.pl

   1 #!/usr/bin/perl
   2 use IO::File ();
   3 use File::Find qw(find);
   4 use Text::Wrap qw(wrap);
   5 use Getopt::Long qw(GetOptions);
   6 use Pod::Usage qw(pod2usage);
   7 use strict;
   8
   9 my %opt = (
  10   hide   => [],
  11   frames => 3,
  12   debug  => 0,
  13 );
  14
  15 GetOptions( \%opt,
  16           qw(
  17             hide=s@
  18             output-file=s
  19             frames=i
  20             debug+
  21           ) ) or pod2usage(2);
  22
  23 my %hide;
  24 my $hide_re = join '|', map { /^\w+$/ && ++$hide{$_} ? () : $_ } @{$opt{hide}};
  25 $hide_re and $hide_re = qr/^(?:$hide_re)$/o;
  26
  27 my $fh = \*STDOUT;
  28 if (exists $opt{'output-file'}) {
  29   $fh = new IO::File ">$opt{'output-file'}"
  30         or die "$opt{'output-file'}: $!\n";
  31 }
  32
  33 my(%error, %leak);
  34
  35 find({wanted => \&filter, no_chdir => 1}, '.');
  36 summary($fh);
  37
  38 exit 0;
  39
  40 sub summary {
  41   my $fh = shift;
  42
  43   $Text::Wrap::columns = 80;
  44
  45   print $fh "MEMORY ACCESS ERRORS\n\n";
  46
  47   for my $e (sort keys %error) {
  48     print $fh qq("$e"\n);
  49     for my $frame (sort keys %{$error{$e}}) {
  50       print $fh ' 'x4, "$frame\n",
  51             wrap(' 'x8, ' 'x8, join ', ', sort keys %{$error{$e}{$frame}}),
  52             "\n";
  53     }
  54     print $fh "\n";
  55   }
  56
  57   print $fh "\nMEMORY LEAKS\n\n";
  58
  59   for my $l (sort keys %leak) {
  60     print $fh qq("$l"\n);
  61     for my $frames (sort keys %{$leak{$l}}) {
  62       my @stack = split /</, $frames;
  63       print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
  64             wrap(' 'x8, ' 'x8, join ', ', sort keys %{$leak{$l}{$frames}}),
  65             "\n\n";
  66     }
  67   }
  68 }
  69
  70 sub filter {
  71   debug(1, "$File::Find::name\n");
  72
  73   /(.*)\.valgrind$/ or return;
  74
  75   my $test = $1;
  76   $test =~ s/^[.t]\///g;
  77
  78   my @l = map { chomp; s/^==\d+==\s?//; $_ }
  79           do { my $fh = new IO::File $_ or die "$_: $!\n"; <$fh> };
  80
  81   my $hexaddr  = '0x[[:xdigit:]]+';
  82   my $topframe = qr/^\s+at $hexaddr:\s+/o;
  83   my $address  = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/o;
  84   my $leak     = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/o;
  85
  86   for my $i (0 .. $#l) {
  87     $l[$i]   =~ $topframe or next; # match on any topmost frame...
  88     $l[$i-1] =~ $address and next; # ...but not if it's only address details
  89     my $line = $l[$i-1];
  90     my $j    = $i;
  91
  92     if ($line =~ $leak) {
  93       debug(2, "LEAK: $line\n");
  94
  95       my $kind   = $1;
  96       my $inperl = 0;
  97       my @stack;
  98
  99       while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+((\w+)\s+\((?:([^:]+:\d+)|[^)]+)\))/o) {
 100         my($frame, $func, $loc) = ($1, $2, $3);
 101         defined $loc && ++$inperl or $inperl && last;
 102         if (exists $hide{$func} or $hide_re && $func =~ $hide_re) {
 103           @stack = ();
 104           last;
 105         }
 106         $inperl <= $opt{frames} and push @stack, $inperl ? $frame : $func;
 107       }
 108
 109       @stack and $inperl and $leak{$kind}{join '<', @stack}{$test}++;
 110     } else {
 111       debug(1, "ERROR: $line\n");
 112
 113       while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+\s+\([^:]+:\d+\))?/o) {
 114         if (defined $1) {
 115           $error{$line}{$1}{$test}++;
 116           last;
 117         }
 118       }
 119     }
 120   }
 121 }
 122
 123 sub debug {
 124   my $level = shift;
 125   $opt{debug} >= $level and print STDERR @_;
 126 }
 127
 128 __END__
 129
 130 =head1 NAME
 131
 132 valgrindpp.pl - A post processor for make test.valgrind
 133
 134 =head1 SYNOPSIS
 135
 136 valgrindpp.pl [B<--output-file>=I<file>] [B<--frames>=I<number>]
 137 [B<--hide>=I<identifier>] [B<--debug>]
 138
 139 =head1 DESCRIPTION
 140
 141 B<valgrindpp.pl> is a post processor for I<.valgrind> files
 142 created during I<make test.valgrind>. It collects all these
 143 files, extracts most of the information and produces a
 144 significantly shorter summary of all detected memory access
 145 errors and memory leaks.
 146
 147 =head1 OPTIONS
 148
 149 =over 4
 150
 151 =item B<--output-file>=I<file>
 152
 153 Redirect the output into I<file>. If this option is not
 154 given, the output goes to I<stdout>.
 155
 156 =item B<--frames>=I<number>
 157
 158 Number of stack frames within the perl source code to
 159 consider when distinguishing between memory leak sources.
 160 Increasing this value will give you a longer backtrace,
 161 while decreasing the number will show you fewer sources
 162 for memory leaks. The default is 3 frames.
 163
 164 =item B<--hide>=I<identifier>
 165
 166 Hide all memory leaks that have I<identifier> in their backtrace.
 167 Useful if you want to hide leaks from functions that are known to
 168 have lots of memory leaks. I<identifier> can also be a regular
 169 expression, in which case all leaks with symbols matching the
 170 expression are hidden. Can be given multiple times.
 171
 172 =item B<--debug>
 173
 174 Increase debug level. Can be given multiple times.
 175
 176 =back
 177
 178 =head1 COPYRIGHT
 179
 180 Copyright 2003 by Marcus Holland-Moritz <mhx@cpan.org>.
 181
 182 This program is free software; you may redistribute it
 183 and/or modify it under the same terms as Perl itself.
 184
 185 =cut