From: Vincent Pit <vince@profvince.com>
Date: Thu, 9 Jul 2009 08:44:04 +0000 (+0200)
Subject: Fix not reporting multiple violations with the same method on the same line
X-Git-Tag: v0.03~1
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=fdfcb1cec5f258ed25e22c7d1fea67e03098b3fd;p=perl%2Fmodules%2FPerl-Critic-Policy-Dynamic-NoIndirect.git

Fix not reporting multiple violations with the same method on the same line
---

diff --git a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
index aa4a03a..5236bda 100644
--- a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
+++ b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
@@ -71,28 +71,27 @@ sub violates_dynamic {
   }
  }
 
- @errs = sort { $a->[3] <=> $b->[3] } @errs;
-
  my @violations;
 
  if (@errs) {
-  my ($err, $obj, $meth, $line);
+  my %errs_tags;
+  for (@errs) {
+   my ($obj, $meth, $line) = @$_[0, 1, 3];
+   $line -= $offset;
+   my $tag = join "\0", $line, $meth, $obj;
+   push @{$errs_tags{$tag}}, [ $obj, $meth ];
+  }
 
   $doc->find(sub {
-   unless ($err) {
-    return 1 unless @errs;
-    $err = shift @errs;
-    ($obj, $meth, $line) = @$err[0, 1, 3];
-    $line -= $offset;
-   }
-
    my $elt = $_[1];
    my $pos = $elt->location;
+   return 0 unless $pos;
 
-   if ($pos and $pos->[0] == $line and $elt eq $meth
-                                   and $elt->snext_sibling eq $obj) {
-    push @violations, [ $obj, $meth, $elt ];
-    undef $err;
+   my $tag = join "\0", $pos->[0], $elt, $elt->snext_sibling;
+   if (my $errs = $errs_tags{$tag}) {
+    push @violations, do { my $e = pop @$errs; push @$e, $elt; $e };
+    delete $errs_tags{$tag} unless @$errs;
+    return 1 unless %errs_tags;
    }
 
    return 0;
diff --git a/t/10-basic.t b/t/10-basic.t
index 29c2f10..68715f2 100644
--- a/t/10-basic.t
+++ b/t/10-basic.t
@@ -5,11 +5,11 @@ use warnings;
 
 my ($tests, $subtests);
 BEGIN {
- $tests    = 13;
+ $tests    = 15;
  $subtests = 3;
 }
 
-use Test::More tests => $tests + $subtests * 21;
+use Test::More tests => $tests + $subtests * 25;
 
 use Perl::Critic::TestUtils qw/pcritique_with_violations/;
 
@@ -72,6 +72,10 @@ my $x = new X    new X;
 ----
 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ]
 ####
+my $x = new X    new Y;
+----
+[ 'new', 'X', 1, 9 ], [ 'new', 'Y', 1, 18 ]
+####
 my $x = new X;
 my $y = new X;
 ----
@@ -107,6 +111,11 @@ my $x = new $obj    new $obj;
 ----
 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
 ####
+our ($o1, $o2);
+my $x = new $o1     new $o2;
+----
+[ 'new', '$o1', 2, 9 ], [ 'new', '$o2', 2, 21 ]
+####
 our $obj;
 my $x = new $obj;
 my $y = new $obj;