git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/t/20_policies.t

   1 #!perl
   2
   3 use 5.006001;
   4 use strict;
   5 use warnings;
   6 use Test::More;
   7 use English qw(-no_match_vars);
   8
   9 # common P::C testing tools
  10 use Perl::Critic::Utils qw( :characters );
  11 use Perl::Critic::TestUtils qw(
  12     pcritique_with_violations
  13     fcritique_with_violations
  14     subtests_in_tree
  15 );
  16 Perl::Critic::TestUtils::block_perlcriticrc();
  17
  18 my $subtests = subtests_in_tree( 't' );
  19
  20 # Check for cmdline limit on policies.  Example:
  21 #   perl -Ilib t/20_policies.t BuiltinFunctions::ProhibitLvalueSubstr
  22 # or
  23 #   perl -Ilib t/20_policies.t t/BuiltinFunctions/ProhibitLvalueSubstr.run
  24 if (@ARGV) {
  25     my @policies = keys %{$subtests}; # get a list of all tests
  26     # This is inefficient, but who cares...
  27     for (@ARGV) {
  28         next if m/::/xms;
  29         if (!s{\A t[\\/](\w+)[\\/](\w+)\.run \z}{$1\::$2}xms) {
  30             die 'Unknown argument ' . $_;
  31         }
  32     }
  33     for my $p (@policies) {
  34         if (0 == grep {$_ eq $p} @ARGV) {
  35             delete $subtests->{$p};
  36         }
  37     }
  38 }
  39
  40 # count how many tests there will be
  41 my $nsubtests = 0;
  42 for my $s (values %$subtests) {
  43     $nsubtests += @$s; # one [pf]critique() test per subtest
  44 }
  45 my $npolicies = scalar keys %$subtests; # one can() test per policy
  46
  47 plan tests => $nsubtests + $npolicies;
  48
  49 for my $policy ( sort keys %$subtests ) {
  50     can_ok( "Perl::Critic::Policy::$policy", 'violates' );
  51     for my $subtest ( @{$subtests->{$policy}} ) {
  52         local $TODO = $subtest->{TODO}; # Is NOT a TODO if it's not set
  53
  54         my $desc =
  55             join ' - ', $policy, "line $subtest->{lineno}", $subtest->{name};
  56
  57         my @violations = $subtest->{filename}
  58             ? eval {
  59                 fcritique_with_violations(
  60                     $policy,
  61                     \$subtest->{code},
  62                     $subtest->{filename},
  63                     $subtest->{parms},
  64                 )
  65             }
  66             : eval {
  67                 pcritique_with_violations(
  68                     $policy,
  69                     \$subtest->{code},
  70                     $subtest->{parms},
  71                 )
  72             };
  73         my $err = $EVAL_ERROR;
  74
  75         my $test_passed;
  76         if ($subtest->{error}) {
  77             if ( 'Regexp' eq ref $subtest->{error} ) {
  78                 $test_passed = like($err, $subtest->{error}, $desc);
  79             }
  80             else {
  81                 $test_passed = ok($err, $desc);
  82             }
  83         }
  84         elsif ($err) {
  85             if ($err =~ m/\A Unable [ ] to [ ] create [ ] policy [ ] [']/xms) {
  86                 # We most likely hit a configuration that a parameter didn't like.
  87                 fail($desc);
  88                 diag($err);
  89                 $test_passed = 0;
  90             }
  91             else {
  92                 die $err;
  93             }
  94         }
  95         else {
  96             my $expected_failures = $subtest->{failures};
  97
  98             # If any optional modules are NOT installed, then there should be no failures.
  99             if ($subtest->{optional_modules}) {
 100               MODULE:
 101                 for my $module (split m/,\s*/xms, $subtest->{optional_modules}) {
 102                     eval "require $module";
 103                     if ($EVAL_ERROR) {
 104                         $expected_failures = 0;
 105                         last MODULE;
 106                     }
 107                 }
 108             }
 109
 110             $test_passed = is(scalar @violations, $expected_failures, $desc);
 111         }
 112
 113         if (not $test_passed) {
 114             diag("Violation found: $_") foreach @violations;
 115         }
 116     }
 117 }
 118
 119 #-----------------------------------------------------------------------------
 120 # Local Variables:
 121 #   mode: cperl
 122 #   cperl-indent-level: 4
 123 #   fill-column: 78
 124 #   indent-tabs-mode: nil
 125 #   c-indentation-style: bsd
 126 # End:
 127 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :