t/10-basic.t

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