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 Cwd qw(cwd);
   8 use File::Spec;
   9 use strict;
  10
  11 my %opt = (
  12   frames  => 3,
  13   verbose => 0,
  14 );
  15
  16 GetOptions(\%opt, qw(
  17             dir=s
  18             hide=s@
  19             output-file=s
  20             frames=i
  21             verbose+
  22           )) or pod2usage(2);
  23
  24 # Setup the directory to process
  25 if (exists $opt{dir}) {
  26   $opt{dir} = File::Spec->canonpath($opt{dir});
  27 }
  28 else {
  29   # Check if we're in 't'
  30   $opt{dir} = cwd =~ /\/t$/ ? '..' : '.';
  31
  32   # Check if we're in the right directory
  33   -d "$opt{dir}/$_" or die "$0: must be run from the perl source directory"
  34                          . " when --dir is not given\n"
  35       for qw(t lib ext);
  36 }
  37
  38 # Assemble regex for functions whose leaks should be hidden
  39 # (no, a hash won't be significantly faster)
  40 my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' };
  41
  42 # Setup our output file handle
  43 # (do it early, as it may fail)
  44 my $fh = \*STDOUT;
  45 if (exists $opt{'output-file'}) {
  46   $fh = new IO::File ">$opt{'output-file'}"
  47         or die "$0: cannot open $opt{'output-file'} ($!)\n";
  48 }
  49
  50 # These hashes will receive the error and leak summary data:
  51 #
  52 # %error = (
  53 #   error_name => {
  54 #                   stack_frame => {
  55 #                                    test_script => occurences
  56 #                                  }
  57 #                 }
  58 # );
  59 #
  60 # %leak = (
  61 #   leak_type => {
  62 #                  stack_frames => {
  63 #                                    test_script => occurences
  64 #                                  }
  65 #                } # stack frames are separated by '<'s
  66 # );
  67 my(%error, %leak);
  68
  69 # Collect summary data
  70 find({wanted => \&filter, no_chdir => 1}, $opt{dir});
  71
  72 # Write summary
  73 summary($fh);
  74
  75 exit 0;
  76
  77 sub summary {
  78   my $fh = shift;
  79
  80   $Text::Wrap::columns = 80;
  81
  82   print $fh "MEMORY ACCESS ERRORS\n\n";
  83
  84   for my $e (sort keys %error) {
  85     print $fh qq("$e"\n);
  86     for my $frame (sort keys %{$error{$e}}) {
  87       print $fh ' 'x4, "$frame\n",
  88             wrap(' 'x8, ' 'x8, join ', ', sort keys %{$error{$e}{$frame}}),
  89             "\n";
  90     }
  91     print $fh "\n";
  92   }
  93
  94   print $fh "\nMEMORY LEAKS\n\n";
  95
  96   for my $l (sort keys %leak) {
  97     print $fh qq("$l"\n);
  98     for my $frames (sort keys %{$leak{$l}}) {
  99       my @stack = split /</, $frames;
 100       print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
 101             wrap(' 'x8, ' 'x8, join ', ', sort keys %{$leak{$l}{$frames}}),
 102             "\n\n";
 103     }
 104   }
 105 }
 106
 107 sub filter {
 108   debug(2, "$File::Find::name\n");
 109
 110   # Only process '*.t.valgrind' files
 111   /(.*)\.t\.valgrind$/ or return;
 112
 113   # Strip all unnecessary stuff from the test name
 114   my $test = $1;
 115   $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//;
 116
 117   debug(1, "processing $test ($_)\n");
 118
 119   # Get all the valgrind output lines
 120   my @l = map { chomp; s/^==\d+==\s?//; $_ }
 121           do { my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; <$fh> };
 122
 123   # Setup some useful regexes
 124   my $hexaddr  = '0x[[:xdigit:]]+';
 125   my $topframe = qr/^\s+at $hexaddr:\s+/;
 126   my $address  = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/;
 127   my $leak     = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/;
 128
 129   for my $i (0 .. $#l) {
 130     $l[$i]   =~ $topframe or next; # Match on any topmost frame...
 131     $l[$i-1] =~ $address and next; # ...but not if it's only address details
 132     my $line = $l[$i-1]; # The error / leak description line
 133     my $j    = $i;
 134
 135     if ($line =~ $leak) {
 136       debug(2, "LEAK: $line\n");
 137
 138       my $type   = $1;     # Type of leak (still reachable, ...)
 139       my $inperl = 0;      # Are we inside the perl source? (And how deep?)
 140       my @stack;           # Call stack
 141
 142       while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+((\w+)\s+\((?:([^:]+:\d+)|[^)]+)\))/o) {
 143         my($frame, $func, $loc) = ($1, $2, $3);
 144
 145         # If the stack frame is inside perl => increment $inperl
 146         # If we've already been inside perl, but are no longer => leave
 147         defined $loc && ++$inperl or $inperl && last;
 148
 149         # A function that should be hidden? => clear stack and leave
 150         $hidden && $func =~ $hidden and @stack = (), last;
 151
 152         # Add stack frame if it's within our threshold
 153         $inperl <= $opt{frames} and push @stack, $inperl ? $frame : $func;
 154       }
 155
 156       # If there's something on the stack and we've seen perl code,
 157       # add this memory leak to the summary data
 158       @stack and $inperl and $leak{$type}{join '<', @stack}{$test}++;
 159     } else {
 160       debug(1, "ERROR: $line\n");
 161
 162       # Simply find the topmost frame in the call stack within
 163       # the perl source code
 164       while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+\s+\([^:]+:\d+\))?/o) {
 165         if (defined $1) {
 166           $error{$line}{$1}{$test}++;
 167           last;
 168         }
 169       }
 170     }
 171   }
 172 }
 173
 174 sub debug {
 175   my $level = shift;
 176   $opt{verbose} >= $level and print STDERR @_;
 177 }
 178
 179 __END__
 180
 181 =head1 NAME
 182
 183 valgrindpp.pl - A post processor for make test.valgrind
 184
 185 =head1 SYNOPSIS
 186
 187 valgrindpp.pl [B<--dir>=I<dir>] [B<--output-file>=I<file>]
 188 [B<--frames>=I<number>] [B<--hide>=I<identifier>] [B<--verbose>]
 189
 190 =head1 DESCRIPTION
 191
 192 B<valgrindpp.pl> is a post processor for I<.valgrind> files
 193 created during I<make test.valgrind>. It collects all these
 194 files, extracts most of the information and produces a
 195 significantly shorter summary of all detected memory access
 196 errors and memory leaks.
 197
 198 =head1 OPTIONS
 199
 200 =over 4
 201
 202 =item B<--dir>=I<dir>
 203
 204 Recursively process I<.valgrind> files in I<dir>. If this
 205 options is not given, B<valgrindpp.pl> must be run from
 206 either the perl source or the I<t> directory and will process
 207 all I<.valgrind> files within the distribution.
 208
 209 =item B<--output-file>=I<file>
 210
 211 Redirect the output into I<file>. If this option is not
 212 given, the output goes to I<stdout>.
 213
 214 =item B<--frames>=I<number>
 215
 216 Number of stack frames within the perl source code to
 217 consider when distinguishing between memory leak sources.
 218 Increasing this value will give you a longer backtrace,
 219 while decreasing the number will show you fewer sources
 220 for memory leaks. The default is 3 frames.
 221
 222 =item B<--hide>=I<identifier>
 223
 224 Hide all memory leaks that have I<identifier> in their backtrace.
 225 Useful if you want to hide leaks from functions that are known to
 226 have lots of memory leaks. I<identifier> can also be a regular
 227 expression, in which case all leaks with symbols matching the
 228 expression are hidden. Can be given multiple times.
 229
 230 =item B<--verbose>
 231
 232 Increase verbosity level. Can be given multiple times.
 233
 234 =back
 235
 236 =head1 COPYRIGHT
 237
 238 Copyright 2003 by Marcus Holland-Moritz <mhx@cpan.org>.
 239
 240 This program is free software; you may redistribute it
 241 and/or modify it under the same terms as Perl itself.
 242
 243 =cut