X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FPerl-Critic-Policy-Dynamic-NoIndirect.git;a=blobdiff_plain;f=t%2F10-basic.t;h=53629b08447ee7bab28c2b715bf2373b35e7f204;hp=a1b1885751979264c9d691fc8de2340506b76e35;hb=HEAD;hpb=754541e0583f7da9be1ea92f0ea96be44b65cfaa

diff --git a/t/10-basic.t b/t/10-basic.t
index a1b1885..53629b0 100644
--- a/t/10-basic.t
+++ b/t/10-basic.t
@@ -3,20 +3,30 @@
 use strict;
 use warnings;
 
-my ($tests, $subtests);
+my ($tests, $reports, $subtests);
 BEGIN {
- $tests    = 8;
+ $tests    = 28;
+ $reports  = 43;
  $subtests = 3;
 }
 
-use Test::More tests => $tests + $subtests * 14;
+use Test::More tests => $tests + $subtests * $reports;
 
-use Perl::Critic::TestUtils qw/pcritique_with_violations/;
+use Perl::Critic::TestUtils qw<pcritique_with_violations>;
 
 Perl::Critic::TestUtils::block_perlcriticrc();
 
 my $policy = 'Dynamic::NoIndirect';
 
+sub expect {
+ my ($meth, $obj) = @_;
+ $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
+ qr/^Indirect call of method \"\Q$meth\E\" on $obj/,
+}
+
+sub zap (&) { }
+
+TEST:
 {
  local $/ = "####";
 
@@ -25,14 +35,25 @@ my $policy = 'Dynamic::NoIndirect';
  while (<DATA>) {
   s/^\s+//s;
 
-  my ($code, $expected) = split /^-+$/m, $_, 2;
-  my @expected = eval $expected;
-
-  my @violations = eval { pcritique_with_violations($policy, \$code) };
+  my ($code, $expected) = split /^-{4,}$/m, $_, 2;
+  my @expected;
+  {
+   local $@;
+   @expected = eval $expected;
+   if ($@) {
+    diag "Compilation of expected code $id failed: $@";
+    next TEST;
+   }
+  }
 
-  if ($@) {
-   diag "Compilation $id failed: $@";
-   next;
+  my @violations;
+  {
+   local $@;
+   @violations = eval { pcritique_with_violations($policy, \$code) };
+   if ($@) {
+    diag "Critique test $id failed: $@";
+    next TEST;
+   }
   }
 
   is @violations, @expected, "right count of violations $id";
@@ -42,15 +63,13 @@ my $policy = 'Dynamic::NoIndirect';
 
    unless ($exp) {
     fail "Unexpected violation for chunk $id: " . $v->description;
-    next;
+    next TEST;
    }
 
    my $pos = $v->location;
    my ($meth, $obj, $line, $col) = @$exp;
 
-   like $v->description,
-        qr/^Indirect call of method \"\Q$meth\E\" on object \"\Q$obj\E\"/,
-        "description $id";
+   like $v->description, expect($meth, $obj), "description $id";
    is   $pos->[0], $line, "line $id";
    is   $pos->[1], $col,  "column $id";
   }
@@ -64,6 +83,9 @@ my $x = new X;
 ----
 [ 'new', 'X', 1, 9 ]
 ####
+use indirect; my $x = new X;
+----
+####
 my $x = new X; $x = new X;
 ----
 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ]
@@ -72,11 +94,34 @@ 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;
 ----
 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
 ####
+my $x = new
+            X;
+----
+[ 'new', 'X', 1, 9 ]
+####
+my $x = new
+ X new
+    X;
+----
+[ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 4 ]
+####
+my $x = new new;
+----
+[ 'new', 'new', 1, 9 ]
+####
+our $obj;
+use indirect; my $x = new $obj;
+----
+####
 our $obj;
 my $x = new $obj;
 ----
@@ -92,9 +137,83 @@ 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;
 ----
 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
-
+####
+our $obj;
+my $x = new
+            $obj;
+----
+[ 'new', '$obj', 2, 9 ]
+####
+our $obj;
+my $x = new
+ $obj 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 ]
+####
+my $x = $invalid_global_when_strict_is_on; new X;
+----
+[ 'new', 'X', 1, 44 ]