6 my ($tests, $reports, $subtests);
13 use Test::More tests => $tests + $subtests * $reports;
15 use Perl::Critic::TestUtils qw<pcritique_with_violations>;
17 Perl::Critic::TestUtils::block_perlcriticrc();
19 my $policy = 'Dynamic::NoIndirect';
22 my ($meth, $obj) = @_;
23 $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
24 qr/^Indirect call of method \"\Q$meth\E\" on $obj/,
38 my ($code, $expected) = split /^-{4,}$/m, $_, 2;
42 @expected = eval $expected;
44 diag "Compilation of expected code $id failed: $@";
52 @violations = eval { pcritique_with_violations($policy, \$code) };
54 diag "Critique test $id failed: $@";
59 is @violations, @expected, "right count of violations $id";
61 for my $v (@violations) {
62 my $exp = shift @expected;
65 fail "Unexpected violation for chunk $id: " . $v->description;
69 my $pos = $v->location;
70 my ($meth, $obj, $line, $col) = @$exp;
72 like $v->description, expect($meth, $obj), "description $id";
73 is $pos->[0], $line, "line $id";
74 is $pos->[1], $col, "column $id";
86 use indirect; my $x = new X;
89 my $x = new X; $x = new X;
91 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ]
95 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ]
99 [ 'new', 'X', 1, 9 ], [ 'new', 'Y', 1, 18 ]
104 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
115 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 4 ]
119 [ 'new', 'new', 1, 9 ]
122 use indirect; my $x = new $obj;
128 [ 'new', '$obj', 2, 9 ]
131 my $x = new $obj; $x = new $obj;
133 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ]
136 my $x = new $obj new $obj;
138 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
141 my $x = new $o1 new $o2;
143 [ 'new', '$o1', 2, 9 ], [ 'new', '$o2', 2, 21 ]
149 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
155 [ 'new', '$obj', 2, 9 ]
162 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 7 ]
164 my $x = main::zap { };
187 [ 'meh', '{', 1, 9 ], [ 'new', 'X', 2, 2 ]
194 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 3, 2 ]
199 [ 'meh', '{', 1, 9 ], [ 'new', 'X', 1, 17 ]
205 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 17 ]
208 my $x = meh { new X } new $obj;
210 [ 'meh', '{', 2, 9 ], [ 'new', 'X', 2, 15 ], [ 'new', '$obj', 2, 23 ]
213 my $x = meh { new $obj } new X;
215 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 15 ], [ 'new', 'X', 2, 26 ]
217 my $x = $invalid_global_when_strict_is_on; new X;
219 [ 'new', 'X', 1, 44 ]