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 6f4e31f..1e7c1f8 100644 (file)
@@ -10,14 +10,20 @@ use strict;
 
 my %opt = (
   frames  => 3,
 
 my %opt = (
   frames  => 3,
+  lines   => 0,
+  tests   => 0,
+  top     => 0,
   verbose => 0,
 );
 
 GetOptions(\%opt, qw(
             dir=s
   verbose => 0,
 );
 
 GetOptions(\%opt, qw(
             dir=s
+            frames=i
             hide=s@
             hide=s@
+            lines!
             output-file=s
             output-file=s
-            frames=i
+            tests!
+            top=i
             verbose+
           )) or pod2usage(2);
 
             verbose+
           )) or pod2usage(2);
 
@@ -69,41 +75,114 @@ my(%error, %leak);
 # Collect summary data
 find({wanted => \&filter, no_chdir => 1}, $opt{dir});
 
 # 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
 # Write summary
-summary($fh);
+summary($fh, \%error, \%leak);
 
 exit 0;
 
 sub summary {
 
 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";
   print $fh "MEMORY ACCESS ERRORS\n\n";
-  
-  for my $e (sort keys %error) {
+
+  for my $e (sort keys %ne) {
     print $fh qq("$e"\n);
     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 "\n";
   }
-  
+
   print $fh "\nMEMORY LEAKS\n\n";
   print $fh "\nMEMORY LEAKS\n\n";
-  
-  for my $l (sort keys %leak) {
+  for my $l (sort keys %nl) {
     print $fh qq("$l"\n);
     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;
       my @stack = split /</, $frames;
+      $data->{count} > 1 and $stack[-1] .= " [$data->{count} paths]";
       print $fh join('', map { ' 'x4 . "$_:$stack[$_]\n" } 0 .. $#stack ),
       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(2, "$File::Find::name\n");
 
 sub filter {
   debug(2, "$File::Find::name\n");
 
@@ -139,18 +218,20 @@ sub filter {
       my $inperl = 0;      # Are we inside the perl source? (And how deep?)
       my @stack;           # Call stack
 
       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);
+      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
 
         # 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;
+        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
 
         # 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;
+        if ($inperl <= $opt{frames}) {
+          push @stack, $inperl ? "$func:$file:$lineno" : $func;
+        }
       }
 
       # If there's something on the stack and we've seen perl code,
       }
 
       # If there's something on the stack and we've seen perl code,
@@ -161,9 +242,9 @@ sub filter {
 
       # Simply find the topmost frame in the call stack within
       # the perl source code
 
       # 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) {
+      while ($l[$j++] =~ /^\s+(?:at|by) $hexaddr:\s+(?:(\w+)\s+\(([^:]+):(\d+)\))?/o) {
         if (defined $1) {
         if (defined $1) {
-          $error{$line}{$1}{$test}++;
+          $error{$line}{"$1:$2:$3"}{$test}++;
           last;
         }
       }
           last;
         }
       }
@@ -184,8 +265,10 @@ valgrindpp.pl - A post processor for make test.valgrind
 
 =head1 SYNOPSIS
 
 
 =head1 SYNOPSIS
 
-valgrindpp.pl [B<--dir>=I<dir>] [B<--output-file>=I<file>]
-[B<--frames>=I<number>] [B<--hide>=I<identifier>] [B<--verbose>]
+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
 
 
 =head1 DESCRIPTION
 
@@ -206,11 +289,6 @@ 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.
 
 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
-given, the output goes to I<stdout>.
-
 =item B<--frames>=I<number>
 
 Number of stack frames within the perl source code to 
 =item B<--frames>=I<number>
 
 Number of stack frames within the perl source code to 
@@ -227,6 +305,27 @@ 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.
 
 expression, in which case all leaks with symbols matching the
 expression are hidden. Can be given multiple times.
 
+=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 verbosity level. Can be given multiple times.
 =item B<--verbose>
 
 Increase verbosity level. Can be given multiple times.