#!perl
use
5.006001;
bundled_policy_names
names_of_policies_willing_to_work
>
;
our
$VERSION
=
'1.112_002'
;
Perl::Critic::TestUtils::block_perlcriticrc();
my
@names_of_policies_willing_to_work
=
names_of_policies_willing_to_work(
-severity
=>
$SEVERITY_LOWEST
,
-theme
=>
'core'
,
);
my
@native_policy_names
= bundled_policy_names();
my
$total_policies
=
scalar
@names_of_policies_willing_to_work
;
{
my
$all_policy_count
=
scalar
Perl::Critic::Config
->new(
-severity
=>
$SEVERITY_LOWEST
,
-theme
=>
'core'
,
)
->all_policies_enabled_or_not();
plan
tests
=> 93 +
$all_policy_count
;
}
{
my
$last_policy_count
=
$total_policies
+ 1;
for
my
$severity
(
$SEVERITY_LOWEST
..
$SEVERITY_HIGHEST
) {
my
$configuration
=
Perl::Critic::Config->new(
-severity
=>
$severity
,
-theme
=>
'core'
,
);
my
$policy_count
=
scalar
$configuration
->policies();
my
$test_name
=
"Count native policies, severity: $severity"
;
cmp_ok(
$policy_count
,
'<'
,
$last_policy_count
,
$test_name
);
$last_policy_count
=
$policy_count
;
}
}
{
my
%profile
=
map
{
$_
=> {} }
@native_policy_names
;
my
$last_policy_count
=
$total_policies
+ 1;
for
my
$severity
(
$SEVERITY_LOWEST
..
$SEVERITY_HIGHEST
) {
my
%pc_args
= (
-profile
=> \
%profile
,
-severity
=>
$severity
,
-theme
=>
'core'
,
);
my
$critic
= Perl::Critic::Config->new(
%pc_args
);
my
$policy_count
=
scalar
$critic
->policies();
my
$test_name
=
"Count all policies, severity: $severity"
;
cmp_ok(
$policy_count
,
'<'
,
$last_policy_count
,
$test_name
);
$last_policy_count
=
$policy_count
;
}
}
{
my
$configuration
=
Perl::Critic::Config->new(
-severity
=>
$SEVERITY_LOWEST
,
-theme
=>
'core'
,
);
my
%policies_by_name
=
map
{
$_
->get_short_name() =>
$_
}
$configuration
->policies();
foreach
my
$policy
(
$configuration
->all_policies_enabled_or_not() ) {
my
$enabled
=
$policy
->is_enabled();
if
(
delete
$policies_by_name
{
$policy
->get_short_name() } ) {
ok(
$enabled
,
$policy
->get_short_name() .
' is enabled.'
,
);
}
else
{
ok(
!
$enabled
&&
defined
$enabled
,
$policy
->get_short_name() .
' is not enabled.'
,
);
}
}
}
{
my
%profile
= ();
my
$severity
=
$SEVERITY_HIGHEST
;
for
my
$index
( 0 ..
$#names_of_policies_willing_to_work
) {
if
(
$index
and
$index
% 10 == 0) {
$severity
--;
}
if
(
$severity
<
$SEVERITY_LOWEST
) {
$severity
=
$SEVERITY_LOWEST
;
}
$profile
{
$names_of_policies_willing_to_work
[
$index
]} =
{
severity
=>
$severity
};
}
for
my
$severity
(
reverse
$SEVERITY_LOWEST
+1 ..
$SEVERITY_HIGHEST
) {
my
%pc_args
= (
-profile
=> \
%profile
,
-severity
=>
$severity
,
-theme
=>
'core'
,
);
my
$critic
= Perl::Critic::Config->new(
%pc_args
);
my
$policy_count
=
scalar
$critic
->policies();
my
$expected_count
= (
$SEVERITY_HIGHEST
-
$severity
+ 1) * 10;
my
$test_name
=
"user-defined severity level: $severity"
;
is(
$policy_count
,
$expected_count
,
$test_name
);
}
my
%pc_args
= (
-profile
=> \
%profile
,
-severity
=>
$SEVERITY_LOWEST
);
my
$critic
= Perl::Critic::Config->new(
%pc_args
);
my
$policy_count
=
scalar
$critic
->policies();
my
$expected_count
=
$SEVERITY_HIGHEST
* 10;
my
$test_name
=
'user-defined severity, all remaining policies'
;
cmp_ok(
$policy_count
,
'>='
,
$expected_count
,
$test_name
);
}
{
my
$examples_dir
=
'examples'
;
my
$profile
= File::Spec->catfile(
$examples_dir
,
'perlcriticrc'
);
my
$c
= Perl::Critic::Config->new(
-profile
=>
$profile
);
is_deeply([
$c
->exclude()], [
qw(Documentation Naming)
],
'user default exclude from file'
);
is_deeply([
$c
->include()], [
qw(CodeLayout Modules)
],
'user default include from file'
);
is(
$c
->force(), 1,
'user default force from file'
);
is(
$c
->only(), 1,
'user default only from file'
);
is(
$c
->severity(), 3,
'user default severity from file'
);
is(
$c
->theme()->rule(),
'danger || risky && ! pbp'
,
'user default theme from file'
);
is(
$c
->top(), 50,
'user default top from file'
);
is(
$c
->verbose(), 5,
'user default verbose from file'
);
is(
$c
->color_severity_highest(),
'bold red underline'
,
'user default color-severity-highest from file'
);
is(
$c
->color_severity_high(),
'bold magenta'
,
'user default color-severity-high from file'
);
is(
$c
->color_severity_medium(),
'blue'
,
'user default color-severity-medium from file'
);
is(
$c
->color_severity_low(),
$EMPTY
,
'user default color-severity-low from file'
);
is(
$c
->color_severity_lowest(),
$EMPTY
,
'user default color-severity-lowest from file'
);
is_deeply([
$c
->program_extensions], [],
'user default program-extensions from file'
);
is_deeply([
$c
->program_extensions_as_regexes],
[
qr< @{[ quotemeta '.PL' ]} \z >
smx ],
'user default program-extensions from file, as regexes'
);
}
{
my
%profile
= (
'-NamingConventions::Capitalization'
=> {},
'-Miscellanea::RequireRcsKeywords'
=> {},
);
my
@include
=
qw(capital RCS)
;
my
%pc_args
= (
-profile
=> \
%profile
,
-severity
=> 1,
-include
=> \
@include
,
-theme
=>
'core'
,
);
my
@policies
= Perl::Critic::Config->new(
%pc_args
)->policies();
is(
scalar
@policies
,
$total_policies
,
'include pattern matching'
);
}
{
my
@exclude
=
qw(quote mixed VALUES)
;
my
%pc_args
= (
-severity
=> 1,
-exclude
=> \
@exclude
,
);
my
@policies
= Perl::Critic::Config->new(
%pc_args
)->policies();
my
$matches
=
grep
{
my
$pol
=
ref
$_
;
grep
{
$pol
!~ /
$_
/ixms}
@exclude
}
@policies
;
is(
scalar
@policies
,
$matches
,
'exclude pattern matching'
);
}
{
my
@include
=
qw(builtinfunc)
;
my
@exclude
=
qw(block)
;
my
%pc_args
= (
-severity
=> 1,
-include
=> \
@include
,
-exclude
=> \
@exclude
,
);
my
@policies
= Perl::Critic::Config->new(
%pc_args
)->policies();
my
@pol_names
=
map
{
ref
$_
}
@policies
;
is_deeply(
[
grep
{/block/ixms}
@pol_names
],
[],
'include/exclude pattern match had no "block" policies'
,
);
ok(
@{[any {/builtinfunc/ixms}
@pol_names
]},
'include/exclude pattern match had "builtinfunc" policies'
,
);
}
{
my
@switches
=
qw(
-top
-verbose
-theme
-severity
-only
-force
-color
-pager
-allow-unsafe
-criticism-fatal
-color-severity-highest
-color-severity-high
-color-severity-medium
-color-severity-low
-color-severity-lowest
)
;
my
$color
= -t
*STDOUT
?
$TRUE
:
$FALSE
;
my
%undef_args
=
map
{
$_
=>
undef
}
@switches
;
my
$c
= Perl::Critic::Config->new(
%undef_args
);
$c
= Perl::Critic::Config->new(
%undef_args
);
is(
$c
->force(), 0,
'Undefined -force'
);
is(
$c
->only(), 0,
'Undefined -only'
);
is(
$c
->severity(), 5,
'Undefined -severity'
);
is(
$c
->theme()->rule(),
q{}
,
'Undefined -theme'
);
is(
$c
->top(), 0,
'Undefined -top'
);
is(
$c
->color(),
$color
,
'Undefined -color'
);
is(
$c
->pager(),
q{}
,
'Undefined -pager'
);
is(
$c
->unsafe_allowed(), 0,
'Undefined -allow-unsafe'
);
is(
$c
->verbose(), 4,
'Undefined -verbose'
);
is(
$c
->criticism_fatal(), 0,
'Undefined -criticism-fatal'
);
is(
$c
->color_severity_highest(),
$PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT
,
'Undefined -color-severity-highest'
);
is(
$c
->color_severity_high(),
$PROFILE_COLOR_SEVERITY_HIGH_DEFAULT
,
'Undefined -color-severity-high'
);
is(
$c
->color_severity_medium(),
$PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT
,
'Undefined -color-severity-medium'
);
is(
$c
->color_severity_low(),
$PROFILE_COLOR_SEVERITY_LOW_DEFAULT
,
'Undefined -color-severity-low'
);
is(
$c
->color_severity_lowest(),
$PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT
,
'Undefined -color-severity-lowest'
);
my
%zero_args
=
map
{
$_
=> 0 }
grep
{
$_
!~ m/ \A-color-severity- /smx }
@switches
;
$c
= Perl::Critic::Config->new(
%zero_args
);
is(
$c
->force(), 0,
'zero -force'
);
is(
$c
->only(), 0,
'zero -only'
);
is(
$c
->severity(), 1,
'zero -severity'
);
is(
$c
->theme()->rule(),
q{}
,
'zero -theme'
);
is(
$c
->top(), 0,
'zero -top'
);
is(
$c
->color(),
$FALSE
,
'zero -color'
);
is(
$c
->pager(),
$EMPTY
,
'zero -pager'
);
is(
$c
->unsafe_allowed(), 0,
'zero -allow-unsafe'
);
is(
$c
->verbose(), 4,
'zero -verbose'
);
is(
$c
->criticism_fatal(), 0,
'zero -criticism-fatal'
);
my
%empty_args
=
map
{
$_
=>
q{}
}
@switches
;
$c
= Perl::Critic::Config->new(
%empty_args
);
is(
$c
->force(), 0,
'empty -force'
);
is(
$c
->only(), 0,
'empty -only'
);
is(
$c
->severity(), 1,
'empty -severity'
);
is(
$c
->theme->rule(),
q{}
,
'empty -theme'
);
is(
$c
->top(), 0,
'empty -top'
);
is(
$c
->color(),
$FALSE
,
'empty -color'
);
is(
$c
->pager(),
q{}
,
'empty -pager'
);
is(
$c
->unsafe_allowed(), 0,
'empty -allow-unsafe'
);
is(
$c
->verbose(), 4,
'empty -verbose'
);
is(
$c
->criticism_fatal(), 0,
'empty -criticism-fatal'
);
is(
$c
->color_severity_highest(),
$EMPTY
,
'empty -color-severity-highest'
);
is(
$c
->color_severity_high(),
$EMPTY
,
'empty -color-severity-high'
);
is(
$c
->color_severity_medium(),
$EMPTY
,
'empty -color-severity-medium'
);
is(
$c
->color_severity_low(),
$EMPTY
,
'empty -color-severity-low'
);
is(
$c
->color_severity_lowest(),
$EMPTY
,
'empty -color-severity-lowest'
);
}
{
my
%profile
= (
'NamingConventions::Capitalization'
=> {},
'Miscellanea::RequireRcsKeywords'
=> {},
);
my
%pc_config
= (
-severity
=> 1,
-only
=> 1,
-profile
=> \
%profile
);
my
@policies
= Perl::Critic::Config->new(
%pc_config
)->policies();
is(
scalar
@policies
, 2,
'-only switch'
);
}
{
my
%pc_config
= (
'-single-policy'
=>
'ProhibitMagicNumbers'
);
my
@policies
= Perl::Critic::Config->new(
%pc_config
)->policies();
is(
scalar
@policies
, 1,
'-single-policy switch'
);
}
{
my
%true_defaults
= (
force
=> 1,
only
=> 1,
top
=> 10,
'allow-unsafe'
=> 1,
);
my
%profile
= (
'__defaults__'
=> \
%true_defaults
);
my
%pc_config
= (
-force
=> 0,
-only
=> 0,
-top
=> 0,
'-allow-unsafe'
=> 0,
-profile
=> \
%profile
,
);
my
$config
= Perl::Critic::Config->new(
%pc_config
);
is(
$config
->force, 0,
'-force: default is true, arg is false'
);
is(
$config
->only, 0,
'-only: default is true, arg is false'
);
is(
$config
->top, 0,
'-top: default is true, arg is false'
);
is(
$config
->unsafe_allowed, 0,
'-allow-unsafe: default is true, arg is false'
);
}
{
my
%severity_levels
= (
gentle
=>5,
stern
=>4,
harsh
=>3,
cruel
=>2,
brutal
=>1);
while
(
my
(
$name
,
$number
) =
each
%severity_levels
) {
my
$config
= Perl::Critic::Config->new(
-severity
=>
$name
);
is(
$config
->severity(),
$number
,
qq{Severity "$name" is "$number"}
);
}
}
{
my
$config
= Perl::Critic::Config->new(
-profile
=>
'NONE'
);
eval
{
$config
->add_policy(
-policy
=>
'Bogus::Policy'
) };
like(
$EVAL_ERROR
,
qr/Unable [ ] to [ ] create [ ] policy/
xms,
'add_policy w/ bad args'
,
);
eval
{
$config
->add_policy() };
like(
$EVAL_ERROR
,
qr/The [ ] -policy [ ] argument [ ] is [ ] required/
xms,
'add_policy w/o args'
,
);
eval
{ Perl::Critic::Config->new(
-severity
=>
'bogus'
) };
like(
$EVAL_ERROR
,
qr/The value for the global "-severity" option [(]"bogus"[)] is not one of the valid severity names/
ms,
'invalid severity'
);
eval
{ Perl::Critic::Config->new(
'-single-policy'
=>
q<.*>
) };
like(
$EVAL_ERROR
,
qr/matched [ ] multiple [ ] policies/
xms,
'vague -single-policy'
,
);
eval
{ Perl::Critic::Config->new(
'-single-policy'
=>
'bogus'
) };
like(
$EVAL_ERROR
,
qr/did [ ] not [ ] match [ ] any [ ] policies/
xms,
'invalid -single-policy'
,
);
}
{
my
%profile
= (
'NamingConventions::Capitalization'
=> {},
'Miscellanea::RequireRcsKeywords'
=> {},
);
no
warnings
qw(redefine once)
;
local
*Perl::Critic::Policy::Miscellanea::RequireRcsKeywords::is_safe
=
sub
{
return
0};
my
%safe_pc_config
= (
-severity
=> 1,
-only
=> 1,
-profile
=> \
%profile
);
my
@p
= Perl::Critic::Config->new(
%safe_pc_config
)->policies();
is(
scalar
@p
, 1,
'Only loaded safe policies without -unsafe switch'
);
my
%unsafe_pc_config
= (
%safe_pc_config
,
'-allow-unsafe'
=> 1);
@p
= Perl::Critic::Config->new(
%unsafe_pc_config
)->policies();
is(
scalar
@p
, 2,
'Also loaded unsafe policies with -allow-unsafe switch'
);
my
%singular_pc_config
= (
'-single-policy'
=>
'RequireRcsKeywords'
);
@p
= Perl::Critic::Config->new(
%singular_pc_config
)->policies();
is(
scalar
@p
, 1,
'-single-policy always loads Policy, even if unsafe'
);
}
1;