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;
}
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}++;
sub debug {
my $level = shift;
- $opt{debug} >= $level and print STDERR @_;
+ $opt{verbose} >= $level and print STDERR @_;
}
__END__
=head1 SYNOPSIS
-valgrindpp.pl [B<--output-file>=I<file>] [B<--frames>=I<number>]
-[B<--hide>=I<identifier>] [B<--debug>]
+valgrindpp.pl [B<--dir>=I<dir>] [B<--output-file>=I<file>]
+[B<--frames>=I<number>] [B<--hide>=I<identifier>] [B<--verbose>]
=head1 DESCRIPTION
=over 4
+=item B<--dir>=I<dir>
+
+Recursively process I<.valgrind> files in I<dir>. If this
+options is not given, B<valgrindpp.pl> must be run from
+either the perl source or the I<t> directory and will process
+all I<.valgrind> files within the distribution.
+
=item B<--output-file>=I<file>
Redirect the output into I<file>. If this option is not
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
projects / p5sagit/p5-mst-13.2.git / commitdiff