#!perl -T use strict; use warnings; my ($tests, $reports, $subtests); BEGIN { $tests = 28; $reports = 43; $subtests = 3; } use Test::More tests => $tests + $subtests * $reports; use Perl::Critic::TestUtils qw; 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 $/ = "####"; my $id = 1; while () { s/^\s+//s; my ($code, $expected) = split /^-{4,}$/m, $_, 2; my @expected; { local $@; @expected = eval $expected; if ($@) { diag "Compilation of expected code $id failed: $@"; next TEST; } } 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"; for my $v (@violations) { my $exp = shift @expected; unless ($exp) { fail "Unexpected violation for chunk $id: " . $v->description; next TEST; } my $pos = $v->location; my ($meth, $obj, $line, $col) = @$exp; like $v->description, expect($meth, $obj), "description $id"; is $pos->[0], $line, "line $id"; is $pos->[1], $col, "column $id"; } ++$id; } } __DATA__ 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 ] #### 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; ---- [ 'new', '$obj', 2, 9 ] #### our $obj; my $x = new $obj; $x = new $obj; ---- [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ] #### our $obj; 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 ]