t/10-basic.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($tests, $reports, $subtests);
   7 BEGIN {
   8  $tests    = 25;
   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 my $x = new X; $x = new X;
  75 ----
  76 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ]
  77 ####
  78 my $x = new X    new X;
  79 ----
  80 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ]
  81 ####
  82 my $x = new X    new Y;
  83 ----
  84 [ 'new', 'X', 1, 9 ], [ 'new', 'Y', 1, 18 ]
  85 ####
  86 my $x = new X;
  87 my $y = new X;
  88 ----
  89 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
  90 ####
  91 my $x = new
  92             X;
  93 ----
  94 [ 'new', 'X', 1, 9 ]
  95 ####
  96 my $x = new
  97  X new
  98     X;
  99 ----
 100 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 4 ]
 101 ####
 102 my $x = new new;
 103 ----
 104 [ 'new', 'new', 1, 9 ]
 105 ####
 106 our $obj;
 107 my $x = new $obj;
 108 ----
 109 [ 'new', '$obj', 2, 9 ]
 110 ####
 111 our $obj;
 112 my $x = new $obj; $x = new $obj;
 113 ----
 114 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ]
 115 ####
 116 our $obj;
 117 my $x = new $obj    new $obj;
 118 ----
 119 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
 120 ####
 121 our ($o1, $o2);
 122 my $x = new $o1     new $o2;
 123 ----
 124 [ 'new', '$o1', 2, 9 ], [ 'new', '$o2', 2, 21 ]
 125 ####
 126 our $obj;
 127 my $x = new $obj;
 128 my $y = new $obj;
 129 ----
 130 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
 131 ####
 132 our $obj;
 133 my $x = new
 134             $obj;
 135 ----
 136 [ 'new', '$obj', 2, 9 ]
 137 ####
 138 our $obj;
 139 my $x = new
 140  $obj new
 141     $obj;
 142 ----
 143 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 7 ]
 144 ####
 145 my $x = main::zap { };
 146 ----
 147 ####
 148 my $x = meh { };
 149 ----
 150 [ 'meh', '{', 1, 9 ]
 151 ####
 152 my $x = meh {
 153  1
 154 };
 155 ----
 156 [ 'meh', '{', 1, 9 ]
 157 ####
 158 my $x =
 159  meh { 1; 1
 160  };
 161 ----
 162 [ 'meh', '{', 2, 2 ]
 163 ####
 164 my $x = meh {
 165  new X;
 166 };
 167 ----
 168 [ 'meh', '{', 1, 9 ], [ 'new', 'X', 2, 2 ]
 169 ####
 170 our $obj;
 171 my $x = meh {
 172  new $obj;
 173 }
 174 ----
 175 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 3, 2 ]
 176 ####
 177 my $x = meh { } new
 178                 X;
 179 ----
 180 [ 'meh', '{', 1, 9 ], [ 'new', 'X', 1, 17 ]
 181 ####
 182 our $obj;
 183 my $x = meh { } new
 184                 $obj;
 185 ----
 186 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 17 ]
 187 ####
 188 our $obj;
 189 my $x = meh { new X } new $obj;
 190 ----
 191 [ 'meh', '{', 2, 9 ], [ 'new', 'X', 2, 15 ], [ 'new', '$obj', 2, 23 ]
 192 ####
 193 our $obj;
 194 my $x = meh { new $obj } new X;
 195 ----
 196 [ 'meh', '{', 2, 9 ], [ 'new', '$obj', 2, 15 ], [ 'new', 'X', 2, 26 ]