t/10-basic.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($tests, $subtests);
   7 BEGIN {
   8  $tests    = 8;
   9  $subtests = 3;
  10 }
  11
  12 use Test::More tests => $tests + $subtests * 14;
  13
  14 use Perl::Critic::TestUtils qw/pcritique_with_violations/;
  15
  16 Perl::Critic::TestUtils::block_perlcriticrc();
  17
  18 my $policy = 'Dynamic::NoIndirect';
  19
  20 {
  21  local $/ = "####";
  22
  23  my $id = 1;
  24
  25  while (<DATA>) {
  26   s/^\s+//s;
  27
  28   my ($code, $expected) = split /^-+$/m, $_, 2;
  29   my @expected = eval $expected;
  30
  31   my @violations = eval { pcritique_with_violations($policy, \$code) };
  32
  33   if ($@) {
  34    diag "Compilation $id failed: $@";
  35    next;
  36   }
  37
  38   is @violations, @expected, "right count of violations $id";
  39
  40   for my $v (@violations) {
  41    my $exp = shift @expected;
  42
  43    unless ($exp) {
  44     fail "Unexpected violation for chunk $id: " . $v->description;
  45     next;
  46    }
  47
  48    my $pos = $v->location;
  49    my ($meth, $obj, $line, $col) = @$exp;
  50
  51    like $v->description,
  52         qr/^Indirect call of method \"\Q$meth\E\" on object \"\Q$obj\E\"/,
  53         "description $id";
  54    is   $pos->[0], $line, "line $id";
  55    is   $pos->[1], $col,  "column $id";
  56   }
  57
  58   ++$id;
  59  }
  60 }
  61
  62 __DATA__
  63 my $x = new X;
  64 ----
  65 [ 'new', 'X', 1, 9 ]
  66 ####
  67 my $x = new X; $x = new X;
  68 ----
  69 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ]
  70 ####
  71 my $x = new X    new X;
  72 ----
  73 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ]
  74 ####
  75 my $x = new X;
  76 my $y = new X;
  77 ----
  78 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
  79 ####
  80 our $obj;
  81 my $x = new $obj;
  82 ----
  83 [ 'new', '$obj', 2, 9 ]
  84 ####
  85 our $obj;
  86 my $x = new $obj; $x = new $obj;
  87 ----
  88 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ]
  89 ####
  90 our $obj;
  91 my $x = new $obj    new $obj;
  92 ----
  93 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
  94 ####
  95 our $obj;
  96 my $x = new $obj;
  97 my $y = new $obj;
  98 ----
  99 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
 100