3 use File::Find qw(find);
4 use Text::Wrap qw(wrap);
5 use Getopt::Long qw(GetOptions);
6 use Pod::Usage qw(pod2usage);
30 # Setup the directory to process
31 if (exists $opt{dir}) {
32 $opt{dir} = File::Spec->canonpath($opt{dir});
35 # Check if we're in 't'
36 $opt{dir} = cwd =~ /\/t$/ ? '..' : '.';
38 # Check if we're in the right directory
39 -d "$opt{dir}/$_" or die "$0: must be run from the perl source directory"
40 . " when --dir is not given\n"
44 # Assemble regex for functions whose leaks should be hidden
45 # (no, a hash won't be significantly faster)
46 my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' };
48 # Setup our output file handle
49 # (do it early, as it may fail)
51 if (exists $opt{'output-file'}) {
52 $fh = new IO::File ">$opt{'output-file'}"
53 or die "$0: cannot open $opt{'output-file'} ($!)\n";
56 # These hashes will receive the error and leak summary data:
61 # test_script => occurences
69 # test_script => occurences
71 # } # stack frames are separated by '<'s
75 # Collect summary data
76 find({wanted => \&filter, no_chdir => 1}, $opt{dir});
78 # Format the output nicely
79 $Text::Wrap::columns = 80;
80 $Text::Wrap::unexpand = 0;
83 summary($fh, \%error, \%leak);
88 my($fh, $error, $leak) = @_;
93 for my $e (keys %$error) {
94 for my $f (keys %{$error->{$e}}) {
95 my($func, $file, $line) = split /:/, $f;
96 my $nf = $opt{lines} ? "$func ($file:$line)" : "$func ($file)";
97 $ne{$e}{$nf}{count}++;
98 while (my($k,$v) = each %{$error->{$e}{$f}}) {
99 $ne{$e}{$nf}{tests}{$k} += $v;
105 for my $l (keys %$leak) {
106 for my $s (keys %{$leak->{$l}}) {
107 my $ns = join '<', map {
108 my($func, $file, $line) = split /:/;
110 ? "$func ($file:$line)" : "$func ($file)"
113 $nl{$l}{$ns}{count}++;
114 while (my($k,$v) = each %{$leak->{$l}{$s}}) {
115 $nl{$l}{$ns}{tests}{$k} += $v;
124 for my $what (qw(error leak)) {
125 my @t = sort { $top{$b}{$what} <=> $top{$a}{$what} or $a cmp $b }
126 grep $top{$_}{$what}, keys %top;
127 @t > $opt{top} and splice @t, $opt{top};
129 my $s = $n > 1 ? 's' : '';
131 print $fh "Top $n test scripts for ${what}s:\n\n";
132 for my $i (1 .. $n) {
133 $n = $top{$t[$i-1]}{$what};
134 $s = $n > 1 ? 's' : '';
135 printf $fh " %3s %-40s %3d $what$s\n",
136 $n != $prev ? "$i." : '', $t[$i-1], $n;
143 # Print the real summary
145 print $fh "MEMORY ACCESS ERRORS\n\n";
147 for my $e (sort keys %ne) {
148 print $fh qq("$e"\n);
149 for my $frame (sort keys %{$ne{$e}}) {
150 my $data = $ne{$e}{$frame};
151 my $count = $data->{count} > 1 ? " [$data->{count} paths]" : '';
152 print $fh ' 'x4, "$frame$count\n",
153 format_tests($data->{tests}), "\n";
158 print $fh "\nMEMORY LEAKS\n\n";
160 for my $l (sort keys %nl) {
161 print $fh qq("$l"\n);
162 for my $frames (sort keys %{$nl{$l}}) {
163 my $data = $nl{$l}{$frames};
164 my @stack = split /</, $frames;
165 $data->{count} > 1 and $stack[-1] .= " [$data->{count} paths]";
166 print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
167 format_tests($data->{tests}), "\n\n";
177 return wrap($indent, $indent, join ', ', sort keys %$tests);
180 my $count = keys %$tests;
181 my $s = $count > 1 ? 's' : '';
182 return $indent . "triggered by $count test$s";
187 debug(2, "$File::Find::name\n");
189 # Only process '*.t.valgrind' files
190 /(.*)\.t\.valgrind$/ or return;
192 # Strip all unnecessary stuff from the test name
194 $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//;
196 debug(1, "processing $test ($_)\n");
198 # Get all the valgrind output lines
199 my @l = map { chomp; s/^==\d+==\s?//; $_ }
200 do { my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; <$fh> };
202 # Setup some useful regexes
203 my $hexaddr = '0x[[:xdigit:]]+';
204 my $topframe = qr/^\s+at $hexaddr:\s+/;
205 my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/;
206 my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/;
208 for my $i (0 .. $#l) {
209 $l[$i] =~ $topframe or next; # Match on any topmost frame...
210 $l[$i-1] =~ $address and next; # ...but not if it's only address details
211 my $line = $l[$i-1]; # The error / leak description line
214 if ($line =~ $leak) {
215 debug(2, "LEAK: $line\n");
217 my $type = $1; # Type of leak (still reachable, ...)
218 my $inperl = 0; # Are we inside the perl source? (And how deep?)
219 my @stack; # Call stack
221 while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+)\s+\((?:([^:]+):(\d+)|[^)]+)\)/o) {
222 my($func, $file, $lineno) = ($1, $2, $3);
224 # If the stack frame is inside perl => increment $inperl
225 # If we've already been inside perl, but are no longer => leave
226 defined $file && ++$inperl or $inperl && last;
228 # A function that should be hidden? => clear stack and leave
229 $hidden && $func =~ $hidden and @stack = (), last;
231 # Add stack frame if it's within our threshold
232 if ($inperl <= $opt{frames}) {
233 push @stack, $inperl ? "$func:$file:$lineno" : $func;
237 # If there's something on the stack and we've seen perl code,
238 # add this memory leak to the summary data
239 @stack and $inperl and $leak{$type}{join '<', @stack}{$test}++;
241 debug(1, "ERROR: $line\n");
243 # Simply find the topmost frame in the call stack within
244 # the perl source code
245 while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(?:(\w+)\s+\(([^:]+):(\d+)\))?/o) {
247 $error{$line}{"$1:$2:$3"}{$test}++;
257 $opt{verbose} >= $level and print STDERR @_;
264 valgrindpp.pl - A post processor for make test.valgrind
268 valgrindpp.pl [B<--dir>=I<dir>] [B<--frames>=I<number>]
269 [B<--hide>=I<identifier>] [B<--lines>]
270 [B<--output-file>=I<file>] [B<--tests>]
271 [B<--top>=I<number>] [B<--verbose>]
275 B<valgrindpp.pl> is a post processor for I<.valgrind> files
276 created during I<make test.valgrind>. It collects all these
277 files, extracts most of the information and produces a
278 significantly shorter summary of all detected memory access
279 errors and memory leaks.
285 =item B<--dir>=I<dir>
287 Recursively process I<.valgrind> files in I<dir>. If this
288 options is not given, B<valgrindpp.pl> must be run from
289 either the perl source or the I<t> directory and will process
290 all I<.valgrind> files within the distribution.
292 =item B<--frames>=I<number>
294 Number of stack frames within the perl source code to
295 consider when distinguishing between memory leak sources.
296 Increasing this value will give you a longer backtrace,
297 while decreasing the number will show you fewer sources
298 for memory leaks. The default is 3 frames.
300 =item B<--hide>=I<identifier>
302 Hide all memory leaks that have I<identifier> in their backtrace.
303 Useful if you want to hide leaks from functions that are known to
304 have lots of memory leaks. I<identifier> can also be a regular
305 expression, in which case all leaks with symbols matching the
306 expression are hidden. Can be given multiple times.
310 Show line numbers for stack frames. This is useful for further
311 increasing the error/leak resolution, but makes it harder to
312 compare different reports using I<diff>.
314 =item B<--output-file>=I<file>
316 Redirect the output into I<file>. If this option is not
317 given, the output goes to I<stdout>.
321 List all tests that trigger memory access errors or memory
322 leaks explicitly instead of only printing a count.
324 =item B<--top>=I<number>
326 List the top I<number> test scripts for memory access errors
327 and memory leaks. Set to C<0> for no top-I<n> statistics.
331 Increase verbosity level. Can be given multiple times.
337 Copyright 2003 by Marcus Holland-Moritz <mhx@cpan.org>.
339 This program is free software; you may redistribute it
340 and/or modify it under the same terms as Perl itself.