From: Vincent Pit <vince@profvince.com>
Date: Tue, 14 Jul 2009 19:18:52 +0000 (+0200)
Subject: Make the policy aware of blocks reported by indirect 0.16
X-Git-Tag: v0.04~3
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FPerl-Critic-Policy-Dynamic-NoIndirect.git;a=commitdiff_plain;h=ef89faf5a36a866b83462cad90209f9cc68a7e41

Make the policy aware of blocks reported by indirect 0.16
---

diff --git a/Makefile.PL b/Makefile.PL
index 74305fb..9551442 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -35,7 +35,7 @@ WriteMakefile(
         'Perl::Critic::Utils'         => 0,
         'Perl::Critic::DynamicPolicy' => 0,
         'base'                        => 0,
-        'indirect'                    => '0.15',
+        'indirect'                    => '0.16',
     },
     MIN_PERL_VERSION => 5.008,
     META_MERGE       => \%META,
diff --git a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
index 13bd467..cb88e6b 100644
--- a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
+++ b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
@@ -34,6 +34,12 @@ sub default_severity { $SEVERITY_HIGH }
 sub default_themes   { qw/dynamic maintenance/ }
 sub applies_to       { 'PPI::Document' }
 
+my $tag_obj = sub {
+ my $obj = '' . $_[0];
+ $obj = '{' if $obj =~ /^\s*\{/;
+ $obj;
+};
+
 sub violates_dynamic {
  my ($self, undef, $doc) = @_;
 
@@ -78,7 +84,7 @@ sub violates_dynamic {
   for (@errs) {
    my ($obj, $meth, $line) = @$_[0, 1, 3];
    $line -= $offset;
-   my $tag = join "\0", $line, $meth, $obj;
+   my $tag = join "\0", $line, $meth, $tag_obj->($obj);
    push @{$errs_tags{$tag}}, [ $obj, $meth ];
   }
 
@@ -87,7 +93,7 @@ sub violates_dynamic {
    my $pos = $elt->location;
    return 0 unless $pos;
 
-   my $tag = join "\0", $pos->[0], $elt, $elt->snext_sibling;
+   my $tag = join "\0", $pos->[0], $elt, $tag_obj->($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;
diff --git a/t/10-basic.t b/t/10-basic.t
index 399e552..55215c4 100644
--- a/t/10-basic.t
+++ b/t/10-basic.t
@@ -5,8 +5,8 @@ use warnings;
 
 my ($tests, $reports, $subtests);
 BEGIN {
- $tests    = 15;
- $reports  = 25;
+ $tests    = 25;
+ $reports  = 42;
  $subtests = 3;
 }
 
@@ -24,6 +24,8 @@ sub expect {
  qr/^Indirect call of method \"\Q$meth\E\" on $obj/,
 }
 
+sub zap (&) { }
+
 {
  local $/ = "####";
 
@@ -139,3 +141,56 @@ my $x = new
     $obj;
 ----
 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 7 ]
+####
+my $x = main::zap { };
+----
+####
+my $x = meh { };
+----
+[ 'meh', '{', 1, 9 ]
+####
+my $x = meh {
+ 1
+};
+----
+[ 'meh', '{', 1, 9 ]
+####
+my $x =
+ meh { 1; 1
+ };
+----
+[ 'meh', '{', 2, 2 ]
+####
+my $x = meh {
+ new X;
+};
+----
+[ 'meh', '{', 1, 9 ], [ 'new', 'X', 2, 2 ]
+####
+our $obj;
+my $x = meh {
+ new $obj;
+}
+----
+[ 'meh', '{', 2, 9 ], [ 'new', '$obj', 3, 2 ]
+####
+my $x = meh { } new
+                X;
+----
+[ 'meh', '{', 1, 9 ], [ 'new', 'X', 1, 17 ]
+####
+our $obj;
+my $x = meh { } new
+                $obj;
+----
+[ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 17 ]
+####
+our $obj;
+my $x = meh { new X } new $obj;
+----
+[ 'meh', '{', 2, 9 ], [ 'new', 'X', 2, 15 ], [ 'new', '$obj', 2, 23 ]
+####
+our $obj;
+my $x = meh { new $obj } new X;
+----
+[ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 15 ], [ 'new', 'X', 2, 26 ]