This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more options for valgrindpp.pl
[perl5.git] / Porting / valgrindpp.pl
CommitLineData
77c22dc1
JH
1#!/usr/bin/perl
2use IO::File ();
3use File::Find qw(find);
4use Text::Wrap qw(wrap);
5use Getopt::Long qw(GetOptions);
6use Pod::Usage qw(pod2usage);
85ec34a0
MHM
7use Cwd qw(cwd);
8use File::Spec;
77c22dc1
JH
9use strict;
10
11my %opt = (
85ec34a0 12 frames => 3,
520dabba
MHM
13 lines => 0,
14 tests => 0,
15 top => 0,
85ec34a0 16 verbose => 0,
77c22dc1
JH
17);
18
85ec34a0
MHM
19GetOptions(\%opt, qw(
20 dir=s
520dabba 21 frames=i
77c22dc1 22 hide=s@
520dabba 23 lines!
77c22dc1 24 output-file=s
520dabba
MHM
25 tests!
26 top=i
85ec34a0
MHM
27 verbose+
28 )) or pod2usage(2);
77c22dc1 29
85ec34a0
MHM
30# Setup the directory to process
31if (exists $opt{dir}) {
32 $opt{dir} = File::Spec->canonpath($opt{dir});
33}
34else {
35 # Check if we're in 't'
36 $opt{dir} = cwd =~ /\/t$/ ? '..' : '.';
37
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"
41 for qw(t lib ext);
42}
43
44# Assemble regex for functions whose leaks should be hidden
45# (no, a hash won't be significantly faster)
46my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' };
77c22dc1 47
85ec34a0
MHM
48# Setup our output file handle
49# (do it early, as it may fail)
77c22dc1
JH
50my $fh = \*STDOUT;
51if (exists $opt{'output-file'}) {
52 $fh = new IO::File ">$opt{'output-file'}"
85ec34a0 53 or die "$0: cannot open $opt{'output-file'} ($!)\n";
77c22dc1
JH
54}
55
85ec34a0
MHM
56# These hashes will receive the error and leak summary data:
57#
58# %error = (
59# error_name => {
60# stack_frame => {
61# test_script => occurences
62# }
63# }
64# );
65#
66# %leak = (
67# leak_type => {
68# stack_frames => {
69# test_script => occurences
70# }
71# } # stack frames are separated by '<'s
72# );
77c22dc1
JH
73my(%error, %leak);
74
85ec34a0
MHM
75# Collect summary data
76find({wanted => \&filter, no_chdir => 1}, $opt{dir});
77
520dabba
MHM
78# Format the output nicely
79$Text::Wrap::columns = 80;
80$Text::Wrap::unexpand = 0;
81
85ec34a0 82# Write summary
520dabba 83summary($fh, \%error, \%leak);
77c22dc1
JH
84
85exit 0;
86
87sub summary {
520dabba
MHM
88 my($fh, $error, $leak) = @_;
89 my(%ne, %nl, %top);
90
91 # Prepare the data
92
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;
100 $top{$k}{error}++;
101 }
102 }
103 }
104
105 for my $l (keys %$leak) {
106 for my $s (keys %{$leak->{$l}}) {
107 my $ns = join '<', map {
108 my($func, $file, $line) = split /:/;
109 /:/ ? $opt{lines}
110 ? "$func ($file:$line)" : "$func ($file)"
111 : $_
112 } split /</, $s;
113 $nl{$l}{$ns}{count}++;
114 while (my($k,$v) = each %{$leak->{$l}{$s}}) {
115 $nl{$l}{$ns}{tests}{$k} += $v;
116 $top{$k}{leak}++;
117 }
118 }
119 }
120
121 # Print the Top N
122
123 if ($opt{top}) {
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};
128 my $n = @t;
129 my $s = $n > 1 ? 's' : '';
130 my $prev = 0;
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;
137 $prev = $n;
138 }
139 print $fh "\n";
140 }
141 }
142
143 # Print the real summary
77c22dc1 144
77c22dc1 145 print $fh "MEMORY ACCESS ERRORS\n\n";
520dabba
MHM
146
147 for my $e (sort keys %ne) {
77c22dc1 148 print $fh qq("$e"\n);
520dabba
MHM
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";
77c22dc1
JH
154 }
155 print $fh "\n";
156 }
520dabba 157
77c22dc1 158 print $fh "\nMEMORY LEAKS\n\n";
520dabba
MHM
159
160 for my $l (sort keys %nl) {
77c22dc1 161 print $fh qq("$l"\n);
520dabba
MHM
162 for my $frames (sort keys %{$nl{$l}}) {
163 my $data = $nl{$l}{$frames};
77c22dc1 164 my @stack = split /</, $frames;
520dabba 165 $data->{count} > 1 and $stack[-1] .= " [$data->{count} paths]";
77c22dc1 166 print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
520dabba 167 format_tests($data->{tests}), "\n\n";
77c22dc1
JH
168 }
169 }
170}
171
520dabba
MHM
172sub format_tests {
173 my $tests = shift;
174 my $indent = ' 'x8;
175
176 if ($opt{tests}) {
177 return wrap($indent, $indent, join ', ', sort keys %$tests);
178 }
179 else {
180 my $count = keys %$tests;
181 my $s = $count > 1 ? 's' : '';
182 return $indent . "triggered by $count test$s";
183 }
184}
185
77c22dc1 186sub filter {
85ec34a0 187 debug(2, "$File::Find::name\n");
77c22dc1 188
85ec34a0
MHM
189 # Only process '*.t.valgrind' files
190 /(.*)\.t\.valgrind$/ or return;
77c22dc1 191
85ec34a0 192 # Strip all unnecessary stuff from the test name
77c22dc1 193 my $test = $1;
85ec34a0
MHM
194 $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//;
195
196 debug(1, "processing $test ($_)\n");
77c22dc1 197
85ec34a0 198 # Get all the valgrind output lines
77c22dc1 199 my @l = map { chomp; s/^==\d+==\s?//; $_ }
85ec34a0 200 do { my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; <$fh> };
77c22dc1 201
85ec34a0 202 # Setup some useful regexes
77c22dc1 203 my $hexaddr = '0x[[:xdigit:]]+';
85ec34a0
MHM
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)/;
77c22dc1
JH
207
208 for my $i (0 .. $#l) {
85ec34a0 209 $l[$i] =~ $topframe or next; # Match on any topmost frame...
77c22dc1 210 $l[$i-1] =~ $address and next; # ...but not if it's only address details
85ec34a0 211 my $line = $l[$i-1]; # The error / leak description line
77c22dc1
JH
212 my $j = $i;
213
214 if ($line =~ $leak) {
215 debug(2, "LEAK: $line\n");
216
85ec34a0
MHM
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
77c22dc1 220
520dabba
MHM
221 while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+)\s+\((?:([^:]+):(\d+)|[^)]+)\)/o) {
222 my($func, $file, $lineno) = ($1, $2, $3);
85ec34a0
MHM
223
224 # If the stack frame is inside perl => increment $inperl
225 # If we've already been inside perl, but are no longer => leave
520dabba 226 defined $file && ++$inperl or $inperl && last;
85ec34a0
MHM
227
228 # A function that should be hidden? => clear stack and leave
229 $hidden && $func =~ $hidden and @stack = (), last;
230
231 # Add stack frame if it's within our threshold
520dabba
MHM
232 if ($inperl <= $opt{frames}) {
233 push @stack, $inperl ? "$func:$file:$lineno" : $func;
234 }
77c22dc1
JH
235 }
236
85ec34a0
MHM
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}++;
77c22dc1
JH
240 } else {
241 debug(1, "ERROR: $line\n");
242
85ec34a0
MHM
243 # Simply find the topmost frame in the call stack within
244 # the perl source code
520dabba 245 while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(?:(\w+)\s+\(([^:]+):(\d+)\))?/o) {
77c22dc1 246 if (defined $1) {
520dabba 247 $error{$line}{"$1:$2:$3"}{$test}++;
77c22dc1
JH
248 last;
249 }
250 }
251 }
252 }
253}
254
255sub debug {
256 my $level = shift;
85ec34a0 257 $opt{verbose} >= $level and print STDERR @_;
77c22dc1
JH
258}
259
260__END__
261
262=head1 NAME
263
264valgrindpp.pl - A post processor for make test.valgrind
265
266=head1 SYNOPSIS
267
520dabba
MHM
268valgrindpp.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>]
77c22dc1
JH
272
273=head1 DESCRIPTION
274
275B<valgrindpp.pl> is a post processor for I<.valgrind> files
276created during I<make test.valgrind>. It collects all these
277files, extracts most of the information and produces a
278significantly shorter summary of all detected memory access
279errors and memory leaks.
280
281=head1 OPTIONS
282
283=over 4
284
85ec34a0
MHM
285=item B<--dir>=I<dir>
286
287Recursively process I<.valgrind> files in I<dir>. If this
288options is not given, B<valgrindpp.pl> must be run from
289either the perl source or the I<t> directory and will process
290all I<.valgrind> files within the distribution.
291
77c22dc1
JH
292=item B<--frames>=I<number>
293
294Number of stack frames within the perl source code to
295consider when distinguishing between memory leak sources.
296Increasing this value will give you a longer backtrace,
297while decreasing the number will show you fewer sources
298for memory leaks. The default is 3 frames.
299
300=item B<--hide>=I<identifier>
301
302Hide all memory leaks that have I<identifier> in their backtrace.
303Useful if you want to hide leaks from functions that are known to
304have lots of memory leaks. I<identifier> can also be a regular
305expression, in which case all leaks with symbols matching the
306expression are hidden. Can be given multiple times.
307
520dabba
MHM
308=item B<--lines>
309
310Show line numbers for stack frames. This is useful for further
311increasing the error/leak resolution, but makes it harder to
312compare different reports using I<diff>.
313
314=item B<--output-file>=I<file>
315
316Redirect the output into I<file>. If this option is not
317given, the output goes to I<stdout>.
318
319=item B<--tests>
320
321List all tests that trigger memory access errors or memory
322leaks explicitly instead of only printing a count.
323
324=item B<--top>=I<number>
325
326List the top I<number> test scripts for memory access errors
327and memory leaks. Set to C<0> for no top-I<n> statistics.
328
85ec34a0 329=item B<--verbose>
77c22dc1 330
85ec34a0 331Increase verbosity level. Can be given multiple times.
77c22dc1
JH
332
333=back
334
335=head1 COPYRIGHT
336
337Copyright 2003 by Marcus Holland-Moritz <mhx@cpan.org>.
338
339This program is free software; you may redistribute it
340and/or modify it under the same terms as Perl itself.
341
342=cut