t/10-basic.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 my ($tests, $reports, $subtests);
   7 BEGIN {
   8  $tests    = 15;
   9  $reports  = 25;
  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 {
  28  local $/ = "####";
  29
  30  my $id = 1;
  31
  32  while (<DATA>) {
  33   s/^\s+//s;
  34
  35   my ($code, $expected) = split /^-{4,}$/m, $_, 2;
  36   my @expected = eval $expected;
  37
  38   my @violations = eval { pcritique_with_violations($policy, \$code) };
  39
  40   if ($@) {
  41    diag "Compilation $id failed: $@";
  42    next;
  43   }
  44
  45   is @violations, @expected, "right count of violations $id";
  46
  47   for my $v (@violations) {
  48    my $exp = shift @expected;
  49
  50    unless ($exp) {
  51     fail "Unexpected violation for chunk $id: " . $v->description;
  52     next;
  53    }
  54
  55    my $pos = $v->location;
  56    my ($meth, $obj, $line, $col) = @$exp;
  57
  58    like $v->description, expect($meth, $obj), "description $id";
  59    is   $pos->[0], $line, "line $id";
  60    is   $pos->[1], $col,  "column $id";
  61   }
  62
  63   ++$id;
  64  }
  65 }
  66
  67 __DATA__
  68 my $x = new X;
  69 ----
  70 [ 'new', 'X', 1, 9 ]
  71 ####
  72 my $x = new X; $x = new X;
  73 ----
  74 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 21 ]
  75 ####
  76 my $x = new X    new X;
  77 ----
  78 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 1, 18 ]
  79 ####
  80 my $x = new X    new Y;
  81 ----
  82 [ 'new', 'X', 1, 9 ], [ 'new', 'Y', 1, 18 ]
  83 ####
  84 my $x = new X;
  85 my $y = new X;
  86 ----
  87 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 9 ]
  88 ####
  89 my $x = new
  90             X;
  91 ----
  92 [ 'new', 'X', 1, 9 ]
  93 ####
  94 my $x = new
  95  X new
  96     X;
  97 ----
  98 [ 'new', 'X', 1, 9 ], [ 'new', 'X', 2, 4 ]
  99 ####
 100 my $x = new new;
 101 ----
 102 [ 'new', 'new', 1, 9 ]
 103 ####
 104 our $obj;
 105 my $x = new $obj;
 106 ----
 107 [ 'new', '$obj', 2, 9 ]
 108 ####
 109 our $obj;
 110 my $x = new $obj; $x = new $obj;
 111 ----
 112 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 24 ]
 113 ####
 114 our $obj;
 115 my $x = new $obj    new $obj;
 116 ----
 117 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 2, 21 ]
 118 ####
 119 our ($o1, $o2);
 120 my $x = new $o1     new $o2;
 121 ----
 122 [ 'new', '$o1', 2, 9 ], [ 'new', '$o2', 2, 21 ]
 123 ####
 124 our $obj;
 125 my $x = new $obj;
 126 my $y = new $obj;
 127 ----
 128 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 9 ]
 129 ####
 130 our $obj;
 131 my $x = new
 132             $obj;
 133 ----
 134 [ 'new', '$obj', 2, 9 ]
 135 ####
 136 our $obj;
 137 my $x = new
 138  $obj new
 139     $obj;
 140 ----
 141 [ 'new', '$obj', 2, 9 ], [ 'new', '$obj', 3, 7 ]