From: Marcus Holland-Moritz Date: Thu, 28 Aug 2003 09:43:49 +0000 (+0200) Subject: valgrindpp.pl X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=85ec34a020ccb84efde2e739211e38343f8c3f04;p=p5sagit%2Fp5-mst-13.2.git valgrindpp.pl From: "Marcus Holland-Moritz" Message-ID: <002701c36d38$1edb71c0$ae4eeed9@R2D2> p4raw-id: //depot/perl@20925 --- diff --git a/Porting/valgrindpp.pl b/Porting/valgrindpp.pl index 4ae539c..6f4e31f 100644 --- a/Porting/valgrindpp.pl +++ b/Porting/valgrindpp.pl @@ -4,35 +4,72 @@ use File::Find qw(find); use Text::Wrap qw(wrap); use Getopt::Long qw(GetOptions); use Pod::Usage qw(pod2usage); +use Cwd qw(cwd); +use File::Spec; use strict; my %opt = ( - hide => [], - frames => 3, - debug => 0, + frames => 3, + verbose => 0, ); -GetOptions( \%opt, - qw( +GetOptions(\%opt, qw( + dir=s hide=s@ output-file=s frames=i - debug+ - ) ) or pod2usage(2); + verbose+ + )) or pod2usage(2); -my %hide; -my $hide_re = join '|', map { /^\w+$/ && ++$hide{$_} ? () : $_ } @{$opt{hide}}; -$hide_re and $hide_re = qr/^(?:$hide_re)$/o; +# Setup the directory to process +if (exists $opt{dir}) { + $opt{dir} = File::Spec->canonpath($opt{dir}); +} +else { + # Check if we're in 't' + $opt{dir} = cwd =~ /\/t$/ ? '..' : '.'; + + # Check if we're in the right directory + -d "$opt{dir}/$_" or die "$0: must be run from the perl source directory" + . " when --dir is not given\n" + for qw(t lib ext); +} + +# Assemble regex for functions whose leaks should be hidden +# (no, a hash won't be significantly faster) +my $hidden = do { local $"='|'; $opt{hide} ? qr/^(?:@{$opt{hide}})$/o : '' }; +# Setup our output file handle +# (do it early, as it may fail) my $fh = \*STDOUT; if (exists $opt{'output-file'}) { $fh = new IO::File ">$opt{'output-file'}" - or die "$opt{'output-file'}: $!\n"; + or die "$0: cannot open $opt{'output-file'} ($!)\n"; } +# These hashes will receive the error and leak summary data: +# +# %error = ( +# error_name => { +# stack_frame => { +# test_script => occurences +# } +# } +# ); +# +# %leak = ( +# leak_type => { +# stack_frames => { +# test_script => occurences +# } +# } # stack frames are separated by '<'s +# ); my(%error, %leak); -find({wanted => \&filter, no_chdir => 1}, '.'); +# Collect summary data +find({wanted => \&filter, no_chdir => 1}, $opt{dir}); + +# Write summary summary($fh); exit 0; @@ -68,48 +105,62 @@ sub summary { } sub filter { - debug(1, "$File::Find::name\n"); + debug(2, "$File::Find::name\n"); - /(.*)\.valgrind$/ or return; + # Only process '*.t.valgrind' files + /(.*)\.t\.valgrind$/ or return; + # Strip all unnecessary stuff from the test name my $test = $1; - $test =~ s/^[.t]\///g; + $test =~ s/^(?:(?:\Q$opt{dir}\E|[.t])\/)+//; + + debug(1, "processing $test ($_)\n"); + # Get all the valgrind output lines my @l = map { chomp; s/^==\d+==\s?//; $_ } - do { my $fh = new IO::File $_ or die "$_: $!\n"; <$fh> }; + do { my $fh = new IO::File $_ or die "$0: cannot open $_ ($!)\n"; <$fh> }; + # Setup some useful regexes my $hexaddr = '0x[[:xdigit:]]+'; - my $topframe = qr/^\s+at $hexaddr:\s+/o; - my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/o; - my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/o; + my $topframe = qr/^\s+at $hexaddr:\s+/; + my $address = qr/^\s+Address $hexaddr is \d+ bytes (?:before|inside|after) a block of size \d+/; + my $leak = qr/^\s*\d+ bytes in \d+ blocks are (still reachable|(?:definite|possib)ly lost)/; for my $i (0 .. $#l) { - $l[$i] =~ $topframe or next; # match on any topmost frame... + $l[$i] =~ $topframe or next; # Match on any topmost frame... $l[$i-1] =~ $address and next; # ...but not if it's only address details - my $line = $l[$i-1]; + my $line = $l[$i-1]; # The error / leak description line my $j = $i; if ($line =~ $leak) { debug(2, "LEAK: $line\n"); - my $kind = $1; - my $inperl = 0; - my @stack; + my $type = $1; # Type of leak (still reachable, ...) + my $inperl = 0; # Are we inside the perl source? (And how deep?) + my @stack; # Call stack while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+((\w+)\s+\((?:([^:]+:\d+)|[^)]+)\))/o) { my($frame, $func, $loc) = ($1, $2, $3); + + # If the stack frame is inside perl => increment $inperl + # If we've already been inside perl, but are no longer => leave defined $loc && ++$inperl or $inperl && last; - if (exists $hide{$func} or $hide_re && $func =~ $hide_re) { - @stack = (); - last; - } + + # A function that should be hidden? => clear stack and leave + $hidden && $func =~ $hidden and @stack = (), last; + + # Add stack frame if it's within our threshold $inperl <= $opt{frames} and push @stack, $inperl ? $frame : $func; } - @stack and $inperl and $leak{$kind}{join '<', @stack}{$test}++; + # If there's something on the stack and we've seen perl code, + # add this memory leak to the summary data + @stack and $inperl and $leak{$type}{join '<', @stack}{$test}++; } else { debug(1, "ERROR: $line\n"); + # Simply find the topmost frame in the call stack within + # the perl source code while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+\s+\([^:]+:\d+\))?/o) { if (defined $1) { $error{$line}{$1}{$test}++; @@ -122,7 +173,7 @@ sub filter { sub debug { my $level = shift; - $opt{debug} >= $level and print STDERR @_; + $opt{verbose} >= $level and print STDERR @_; } __END__ @@ -133,8 +184,8 @@ valgrindpp.pl - A post processor for make test.valgrind =head1 SYNOPSIS -valgrindpp.pl [B<--output-file>=I] [B<--frames>=I] -[B<--hide>=I] [B<--debug>] +valgrindpp.pl [B<--dir>=I] [B<--output-file>=I] +[B<--frames>=I] [B<--hide>=I] [B<--verbose>] =head1 DESCRIPTION @@ -148,6 +199,13 @@ errors and memory leaks. =over 4 +=item B<--dir>=I + +Recursively process I<.valgrind> files in I. If this +options is not given, B must be run from +either the perl source or the I directory and will process +all I<.valgrind> files within the distribution. + =item B<--output-file>=I Redirect the output into I. If this option is not @@ -169,9 +227,9 @@ have lots of memory leaks. I can also be a regular expression, in which case all leaks with symbols matching the expression are hidden. Can be given multiple times. -=item B<--debug> +=item B<--verbose> -Increase debug level. Can be given multiple times. +Increase verbosity level. Can be given multiple times. =back