t/10-basic.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($tests, $subtests);
   7 BEGIN {
   8  $tests    = 15;
   9  $subtests = 3;
  10 }
  11
  12 use Test::More tests => $tests + $subtests * 25;
  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    new Y;
  76 ----
  77 [ 'new', 'X', 1, 9 ], [ 'new', 'Y', 1, 18 ]
  78 ####
  79 my $x = new X;
  80 my $y = new X;
  81 ----
  82 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
  83 ####
  84 my $x = new
  85             X;
  86 ----
  87 [ 'new', 'X', 1, 9 ]
  88 ####
  89 my $x = new
  90  X new
  91     X;
  92 ----
  93 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 4 ]
  94 ####
  95 my $x = new new;
  96 ----
  97 [ 'new', 'new', 1, 9 ]
  98 ####
  99 our $obj;
 100 my $x = new $obj;
 101 ----
 102 [ 'new', '$obj', 2, 9 ]
 103 ####
 104 our $obj;
 105 my $x = new $obj; $x = new $obj;
 106 ----
 107 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ]
 108 ####
 109 our $obj;
 110 my $x = new $obj    new $obj;
 111 ----
 112 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
 113 ####
 114 our ($o1, $o2);
 115 my $x = new $o1     new $o2;
 116 ----
 117 [ 'new', '$o1', 2, 9 ], [ 'new', '$o2', 2, 21 ]
 118 ####
 119 our $obj;
 120 my $x = new $obj;
 121 my $y = new $obj;
 122 ----
 123 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
 124 ####
 125 our $obj;
 126 my $x = new
 127             $obj;
 128 ----
 129 [ 'new', '$obj', 2, 9 ]
 130 ####
 131 our $obj;
 132 my $x = new
 133  $obj new
 134     $obj;
 135 ----
 136 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 7 ]