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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
#!perl
# Test that all the problems in an rc file get reported and not just the first
# one that is found.
use 5.010001;
use strict;
use warnings;
use English qw< -no_match_vars >;
use Readonly;
use Test::More;
use Perl::Critic::PolicyFactory (-test => 1);
use Perl::Critic;
use Perl::Critic::Utils::Constants qw< $_MODULE_VERSION_TERM_ANSICOLOR >;
our $VERSION = '1.156';
use Perl::Critic::TestUtils;
Perl::Critic::TestUtils::assert_version( $VERSION );
my @color_severity_params;
my $skip_color_severity =
eval {
require Term::ANSIColor;
Term::ANSIColor->VERSION( $_MODULE_VERSION_TERM_ANSICOLOR );
1;
}
? undef
: "Term::ANSIColor $_MODULE_VERSION_TERM_ANSICOLOR is not available";
# We can not do the color-severity tests if Term::ANSIColor is not available,
# because without Term::ANSIColor the parameters are not validated, so any
# value will be accepted and we will not get any errors from them.
$skip_color_severity
or @color_severity_params = qw<
color-severity-highest
color-severity-high
color-severity-medium
color-severity-low
color-severity-lowest
>;
plan tests => 13 + scalar @color_severity_params;
Readonly::Scalar my $PROFILE => 't/01_bad_perlcriticrc';
Readonly::Scalar my $NO_ENABLED_POLICIES_MESSAGE =>
q<There are no enabled policies.>;
Readonly::Scalar my $INVALID_PARAMETER_MESSAGE =>
q<The BuiltinFunctions::RequireBlockGrep policy doesn't take a "no_such_parameter" option.>;
Readonly::Scalar my $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX =>
q<The value for the Documentation::RequirePodSections "source" option ("Zen_and_the_Art_of_Motorcycle_Maintenance") is not one of the allowed values: >;
eval {
Perl::Critic->new( '-profile' => $PROFILE );
};
my $test_passed;
my $eval_result = $EVAL_ERROR;
$test_passed =
ok( $eval_result, 'should get an exception when using a bad rc file' );
die "No point in continuing.\n" if not $test_passed;
$test_passed =
isa_ok(
$eval_result,
'Perl::Critic::Exception::AggregateConfiguration',
'$EVAL_ERROR', ## no critic (RequireInterpolationOfMetachars)
);
if ( not $test_passed ) {
diag( $eval_result );
die "No point in continuing.\n";
}
my @exceptions = @{ $eval_result->exceptions() };
my @parameters = (
qw<
exclude
include
profile-strictness
severity
single-policy
theme
top
verbose
>,
@color_severity_params,
);
my %expected_regexes =
map
{ $_ => generate_global_message_regex( $_, $PROFILE ) }
@parameters;
my $expected_exceptions = 1 + scalar @parameters;
is(
scalar @exceptions,
$expected_exceptions,
'should have received the correct number of exceptions'
);
if (@exceptions != $expected_exceptions) {
foreach my $exception (@exceptions) {
diag "Exception: $exception";
}
}
while (my ($parameter, $regex) = each %expected_regexes) {
is(
( scalar grep { m/$regex/xms } @exceptions ),
1,
"should have received one and only one exception for $parameter",
);
}
is(
( scalar grep { $INVALID_PARAMETER_MESSAGE eq $_ } @exceptions ),
0,
'should not have received an extra-parameter exception',
);
# Test that we get an exception for bad individual policy configuration.
# The selection of RequirePodSections is arbitrary.
is(
( scalar grep { is_require_pod_sections_source_exception($_) } @exceptions ),
1,
'should have received an invalid source exception for RequirePodSections',
);
sub generate_global_message_regex {
my ($parameter, $file) = @_;
return
qr<
\A
The [ ] value [ ] for [ ] the [ ] global [ ]
"$parameter"
.*
found [ ] in [ ] "$file"
>xms;
}
sub is_require_pod_sections_source_exception {
my ($exception) = @_;
my $prefix =
substr
$exception,
0,
length $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX;
return $prefix eq $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX;
}
##############################################################################
# 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 :
|
