This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
more options for valgrindpp.pl
[perl5.git] / Porting / valgrindpp.pl
index 4ae539c..1e7c1f8 100644 (file)
@@ -4,115 +4,247 @@ 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,
+  lines   => 0,
+  tests   => 0,
+  top     => 0,
+  verbose => 0,
 );
 
-GetOptions( \%opt,
-          qw(
+GetOptions(\%opt, qw(
+            dir=s
+            frames=i
             hide=s@
+            lines!
             output-file=s
-            frames=i
-            debug+
-          ) ) or pod2usage(2);
+            tests!
+            top=i
+            verbose+
+          )) or pod2usage(2);
+
+# 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);
+}
 
-my %hide;
-my $hide_re = join '|', map { /^\w+$/ && ++$hide{$_} ? () : $_ } @{$opt{hide}};
-$hide_re and $hide_re = qr/^(?:$hide_re)$/o;
+# 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}, '.');
-summary($fh);
+# Collect summary data
+find({wanted => \&filter, no_chdir => 1}, $opt{dir});
+
+# Format the output nicely
+$Text::Wrap::columns = 80;
+$Text::Wrap::unexpand = 0;
+
+# Write summary
+summary($fh, \%error, \%leak);
 
 exit 0;
 
 sub summary {
-  my $fh = shift;
+  my($fh, $error, $leak) = @_;
+  my(%ne, %nl, %top);
+
+  # Prepare the data
+
+  for my $e (keys %$error) {
+    for my $f (keys %{$error->{$e}}) {
+      my($func, $file, $line) = split /:/, $f;
+      my $nf = $opt{lines} ? "$func ($file:$line)" : "$func ($file)";
+      $ne{$e}{$nf}{count}++;
+      while (my($k,$v) = each %{$error->{$e}{$f}}) {
+        $ne{$e}{$nf}{tests}{$k} += $v;
+        $top{$k}{error}++;
+      }
+    }
+  }
+
+  for my $l (keys %$leak) {
+    for my $s (keys %{$leak->{$l}}) {
+      my $ns = join '<', map {
+                 my($func, $file, $line) = split /:/;
+                 /:/ ? $opt{lines}
+                       ? "$func ($file:$line)" : "$func ($file)"
+                     : $_
+               } split /</, $s;
+      $nl{$l}{$ns}{count}++;
+      while (my($k,$v) = each %{$leak->{$l}{$s}}) {
+        $nl{$l}{$ns}{tests}{$k} += $v;
+        $top{$k}{leak}++;
+      }
+    }
+  }
+
+  # Print the Top N
+
+  if ($opt{top}) {
+    for my $what (qw(error leak)) {
+      my @t = sort { $top{$b}{$what} <=> $top{$a}{$what} or $a cmp $b }
+              grep $top{$_}{$what}, keys %top;
+      @t > $opt{top} and splice @t, $opt{top};
+      my $n = @t;
+      my $s = $n > 1 ? 's' : '';
+      my $prev = 0;
+      print $fh "Top $n test scripts for ${what}s:\n\n";
+      for my $i (1 .. $n) {
+        $n = $top{$t[$i-1]}{$what};
+        $s = $n > 1 ? 's' : '';
+        printf $fh "    %3s %-40s %3d $what$s\n",
+                   $n != $prev ? "$i." : '', $t[$i-1], $n;
+        $prev = $n;
+      }
+      print $fh "\n";
+    }
+  }
+
+  # Print the real summary
 
-  $Text::Wrap::columns = 80;
-  
   print $fh "MEMORY ACCESS ERRORS\n\n";
-  
-  for my $e (sort keys %error) {
+
+  for my $e (sort keys %ne) {
     print $fh qq("$e"\n);
-    for my $frame (sort keys %{$error{$e}}) {
-      print $fh ' 'x4, "$frame\n",
-            wrap(' 'x8, ' 'x8, join ', ', sort keys %{$error{$e}{$frame}}),
-            "\n";
+    for my $frame (sort keys %{$ne{$e}}) {
+      my $data = $ne{$e}{$frame};
+      my $count = $data->{count} > 1 ? " [$data->{count} paths]" : '';
+      print $fh ' 'x4, "$frame$count\n",
+                format_tests($data->{tests}), "\n";
     }
     print $fh "\n";
   }
-  
+
   print $fh "\nMEMORY LEAKS\n\n";
-  
-  for my $l (sort keys %leak) {
+  for my $l (sort keys %nl) {
     print $fh qq("$l"\n);
-    for my $frames (sort keys %{$leak{$l}}) {
+    for my $frames (sort keys %{$nl{$l}}) {
+      my $data = $nl{$l}{$frames};
       my @stack = split /</, $frames;
+      $data->{count} > 1 and $stack[-1] .= " [$data->{count} paths]";
       print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
-            wrap(' 'x8, ' 'x8, join ', ', sort keys %{$leak{$l}{$frames}}),
-            "\n\n";
+                format_tests($data->{tests}), "\n\n";
     }
   }
 }
 
+sub format_tests {
+  my $tests = shift;
+  my $indent = ' 'x8;
+
+  if ($opt{tests}) {
+    return wrap($indent, $indent, join ', ', sort keys %$tests);
+  }
+  else {
+    my $count = keys %$tests;
+    my $s = $count > 1 ? 's' : '';
+    return $indent . "triggered by $count test$s";
+  }
+}
+
 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);
-        defined $loc && ++$inperl or $inperl && last;
-        if (exists $hide{$func} or $hide_re && $func =~ $hide_re) {
-          @stack = ();
-          last;
+      while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+)\s+\((?:([^:]+):(\d+)|[^)]+)\)/o) {
+        my($func, $file, $lineno) = ($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 $file && ++$inperl or $inperl && 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
+        if ($inperl <= $opt{frames}) {
+          push @stack, $inperl ? "$func:$file:$lineno" : $func;
         }
-        $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");
 
-      while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(\w+\s+\([^:]+:\d+\))?/o) {
+      # 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}++;
+          $error{$line}{"$1:$2:$3"}{$test}++;
           last;
         }
       }
@@ -122,7 +254,7 @@ sub filter {
 
 sub debug {
   my $level = shift;
-  $opt{debug} >= $level and print STDERR @_;
+  $opt{verbose} >= $level and print STDERR @_;
 }
 
 __END__
@@ -133,8 +265,10 @@ 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<--frames>=I<number>]
+[B<--hide>=I<identifier>] [B<--lines>]
+[B<--output-file>=I<file>] [B<--tests>] 
+[B<--top>=I<number>] [B<--verbose>]
 
 =head1 DESCRIPTION
 
@@ -148,10 +282,12 @@ errors and memory leaks.
 
 =over 4
 
-=item B<--output-file>=I<file>
+=item B<--dir>=I<dir>
 
-Redirect the output into I<file>. If this option is not
-given, the output goes to I<stdout>.
+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<--frames>=I<number>
 
@@ -169,9 +305,30 @@ 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<--lines>
+
+Show line numbers for stack frames. This is useful for further
+increasing the error/leak resolution, but makes it harder to
+compare different reports using I<diff>.
+
+=item B<--output-file>=I<file>
+
+Redirect the output into I<file>. If this option is not
+given, the output goes to I<stdout>.
+
+=item B<--tests>
+
+List all tests that trigger memory access errors or memory
+leaks explicitly instead of only printing a count.
+
+=item B<--top>=I<number>
+
+List the top I<number> test scripts for memory access errors
+and memory leaks. Set to C<0> for no top-I<n> statistics.
+
+=item B<--verbose>
 
-Increase debug level. Can be given multiple times.
+Increase verbosity level. Can be given multiple times.
 
 =back