t/10-basic.t

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