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