valgrindpp.pl

From: "Marcus Holland-Moritz" <mhx-perl@gmx.net>
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 (file)
--- 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<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
 
@@ -148,6 +199,13 @@ errors and memory leaks.
 
 =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
@@ -169,9 +227,9 @@ have lots of memory leaks. I<identifier> 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