t/10-basic.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($tests, $reports, $subtests);
   7 BEGIN {
   8  $tests    = 28;
   9  $reports  = 43;
  10  $subtests = 3;
  11 }
  12
  13 use Test::More tests => $tests + $subtests * $reports;
  14
  15 use Perl::Critic::TestUtils qw<pcritique_with_violations>;
  16
  17 Perl::Critic::TestUtils::block_perlcriticrc();
  18
  19 my $policy = 'Dynamic::NoIndirect';
  20
  21 sub expect {
  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/,
  25 }
  26
  27 sub zap (&) { }
  28
  29 TEST:
  30 {
  31  local $/ = "####";
  32
  33  my $id = 1;
  34
  35  while (<DATA>) {
  36   s/^\s+//s;
  37
  38   my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  39   my @expected;
  40   {
  41    local $@;
  42    @expected = eval $expected;
  43    if ($@) {
  44     diag "Compilation of expected code $id failed: $@";
  45     next TEST;
  46    }
  47   }
  48
  49   my @violations;
  50   {
  51    local $@;
  52    @violations = eval { pcritique_with_violations($policy, \$code) };
  53    if ($@) {
  54     diag "Critique test $id failed: $@";
  55     next TEST;
  56    }
  57   }
  58
  59   is @violations, @expected, "right count of violations $id";
  60
  61   for my $v (@violations) {
  62    my $exp = shift @expected;
  63
  64    unless ($exp) {
  65     fail "Unexpected violation for chunk $id: " . $v->description;
  66     next TEST;
  67    }
  68
  69    my $pos = $v->location;
  70    my ($meth, $obj, $line, $col) = @$exp;
  71
  72    like $v->description, expect($meth, $obj), "description $id";
  73    is   $pos->[0], $line, "line $id";
  74    is   $pos->[1], $col,  "column $id";
  75   }
  76
  77   ++$id;
  78  }
  79 }
  80
  81 __DATA__
  82 my $x = new X;
  83 ----
  84 [ 'new', 'X', 1, 9 ]
  85 ####
  86 use indirect; my $x = new X;
  87 ----
  88 ####
  89 my $x = new X; $x = new X;
  90 ----
  91 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ]
  92 ####
  93 my $x = new X    new X;
  94 ----
  95 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ]
  96 ####
  97 my $x = new X    new Y;
  98 ----
  99 [ 'new', 'X', 1, 9 ], [ 'new', 'Y', 1, 18 ]
 100 ####
 101 my $x = new X;
 102 my $y = new X;
 103 ----
 104 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
 105 ####
 106 my $x = new
 107             X;
 108 ----
 109 [ 'new', 'X', 1, 9 ]
 110 ####
 111 my $x = new
 112  X new
 113     X;
 114 ----
 115 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 4 ]
 116 ####
 117 my $x = new new;
 118 ----
 119 [ 'new', 'new', 1, 9 ]
 120 ####
 121 our $obj;
 122 use indirect; my $x = new $obj;
 123 ----
 124 ####
 125 our $obj;
 126 my $x = new $obj;
 127 ----
 128 [ 'new', '$obj', 2, 9 ]
 129 ####
 130 our $obj;
 131 my $x = new $obj; $x = new $obj;
 132 ----
 133 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ]
 134 ####
 135 our $obj;
 136 my $x = new $obj    new $obj;
 137 ----
 138 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
 139 ####
 140 our ($o1, $o2);
 141 my $x = new $o1     new $o2;
 142 ----
 143 [ 'new', '$o1', 2, 9 ], [ 'new', '$o2', 2, 21 ]
 144 ####
 145 our $obj;
 146 my $x = new $obj;
 147 my $y = new $obj;
 148 ----
 149 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
 150 ####
 151 our $obj;
 152 my $x = new
 153             $obj;
 154 ----
 155 [ 'new', '$obj', 2, 9 ]
 156 ####
 157 our $obj;
 158 my $x = new
 159  $obj new
 160     $obj;
 161 ----
 162 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 7 ]
 163 ####
 164 my $x = main::zap { };
 165 ----
 166 ####
 167 my $x = meh { };
 168 ----
 169 [ 'meh', '{', 1, 9 ]
 170 ####
 171 my $x = meh {
 172  1
 173 };
 174 ----
 175 [ 'meh', '{', 1, 9 ]
 176 ####
 177 my $x =
 178  meh { 1; 1
 179  };
 180 ----
 181 [ 'meh', '{', 2, 2 ]
 182 ####
 183 my $x = meh {
 184  new X;
 185 };
 186 ----
 187 [ 'meh', '{', 1, 9 ], [ 'new', 'X', 2, 2 ]
 188 ####
 189 our $obj;
 190 my $x = meh {
 191  new $obj;
 192 }
 193 ----
 194 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 3, 2 ]
 195 ####
 196 my $x = meh { } new
 197                 X;
 198 ----
 199 [ 'meh', '{', 1, 9 ], [ 'new', 'X', 1, 17 ]
 200 ####
 201 our $obj;
 202 my $x = meh { } new
 203                 $obj;
 204 ----
 205 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 17 ]
 206 ####
 207 our $obj;
 208 my $x = meh { new X } new $obj;
 209 ----
 210 [ 'meh', '{', 2, 9 ], [ 'new', 'X', 2, 15 ], [ 'new', '$obj', 2, 23 ]
 211 ####
 212 our $obj;
 213 my $x = meh { new $obj } new X;
 214 ----
 215 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 15 ], [ 'new', 'X', 2, 26 ]
 216 ####
 217 my $x = $invalid_global_when_strict_is_on; new X;
 218 ----
 219 [ 'new', 'X', 1, 44 ]