This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
valgrindpp.pl
[perl5.git] / 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