Commit | Line | Data |
77c22dc1 |
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); |
85ec34a0 |
7 | use Cwd qw(cwd); |
8 | use File::Spec; |
77c22dc1 |
9 | use strict; |
10 | |
11 | my %opt = ( |
85ec34a0 |
12 | frames => 3, |
13 | verbose => 0, |
77c22dc1 |
14 | ); |
15 | |
85ec34a0 |
16 | GetOptions(\%opt, qw( |
17 | dir=s |
77c22dc1 |
18 | hide=s@ |
19 | output-file=s |
20 | frames=i |
85ec34a0 |
21 | verbose+ |
22 | )) or pod2usage(2); |
77c22dc1 |
23 | |
85ec34a0 |
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 : '' }; |
77c22dc1 |
41 | |
85ec34a0 |
42 | # Setup our output file handle |
43 | # (do it early, as it may fail) |
77c22dc1 |
44 | my $fh = \*STDOUT; |
45 | if (exists $opt{'output-file'}) { |
46 | $fh = new IO::File ">$opt{'output-file'}" |
85ec34a0 |
47 | or die "$0: cannot open $opt{'output-file'} ($!)\n"; |
77c22dc1 |
48 | } |
49 | |
85ec34a0 |
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 | # ); |
77c22dc1 |
67 | my(%error, %leak); |
68 | |
85ec34a0 |
69 | # Collect summary data |
70 | find({wanted => \&filter, no_chdir => 1}, $opt{dir}); |
71 | |
72 | # Write summary |
77c22dc1 |
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 { |
85ec34a0 |
108 | debug(2, "$File::Find::name\n"); |
77c22dc1 |
109 | |
85ec34a0 |
110 | # Only process '*.t.valgrind' files |
111 | /(.*)\.t\.valgrind$/ or return; |
77c22dc1 |
112 | |
85ec34a0 |
113 | # Strip all unnecessary stuff from the test name |
77c22dc1 |
114 | my $test = $1; |
85ec34a0 |
115 | $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//; |
116 | |
117 | debug(1, "processing $test ($_)\n"); |
77c22dc1 |
118 | |
85ec34a0 |
119 | # Get all the valgrind output lines |
77c22dc1 |
120 | my @l = map { chomp; s/^==\d+==\s?//; $_ } |
85ec34a0 |
121 | do { my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; <$fh> }; |
77c22dc1 |
122 | |
85ec34a0 |
123 | # Setup some useful regexes |
77c22dc1 |
124 | my $hexaddr = '0x[[:xdigit:]]+'; |
85ec34a0 |
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)/; |
77c22dc1 |
128 | |
129 | for my $i (0 .. $#l) { |
85ec34a0 |
130 | $l[$i] =~ $topframe or next; # Match on any topmost frame... |
77c22dc1 |
131 | $l[$i-1] =~ $address and next; # ...but not if it's only address details |
85ec34a0 |
132 | my $line = $l[$i-1]; # The error / leak description line |
77c22dc1 |
133 | my $j = $i; |
134 | |
135 | if ($line =~ $leak) { |
136 | debug(2, "LEAK: $line\n"); |
137 | |
85ec34a0 |
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 |
77c22dc1 |
141 | |
142 | while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+((\w+)\s+\((?:([^:]+:\d+)|[^)]+)\))/o) { |
143 | my($frame, $func, $loc) = ($1, $2, $3); |
85ec34a0 |
144 | |
145 | # If the stack frame is inside perl => increment $inperl |
146 | # If we've already been inside perl, but are no longer => leave |
77c22dc1 |
147 | defined $loc && ++$inperl or $inperl && last; |
85ec34a0 |
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 |
77c22dc1 |
153 | $inperl <= $opt{frames} and push @stack, $inperl ? $frame : $func; |
154 | } |
155 | |
85ec34a0 |
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}++; |
77c22dc1 |
159 | } else { |
160 | debug(1, "ERROR: $line\n"); |
161 | |
85ec34a0 |
162 | # Simply find the topmost frame in the call stack within |
163 | # the perl source code |
77c22dc1 |
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; |
85ec34a0 |
176 | $opt{verbose} >= $level and print STDERR @_; |
77c22dc1 |
177 | } |
178 | |
179 | __END__ |
180 | |
181 | =head1 NAME |
182 | |
183 | valgrindpp.pl - A post processor for make test.valgrind |
184 | |
185 | =head1 SYNOPSIS |
186 | |
85ec34a0 |
187 | valgrindpp.pl [B<--dir>=I<dir>] [B<--output-file>=I<file>] |
188 | [B<--frames>=I<number>] [B<--hide>=I<identifier>] [B<--verbose>] |
77c22dc1 |
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 | |
85ec34a0 |
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 | |
77c22dc1 |
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 | |
85ec34a0 |
230 | =item B<--verbose> |
77c22dc1 |
231 | |
85ec34a0 |
232 | Increase verbosity level. Can be given multiple times. |
77c22dc1 |
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 |