DESC
=>
'Package variable declared or used'
,
EXPL
=> [73, 75],
};
sub
evaluate {
my
(
$class
,
$file
,
$tokens
,
$src
,
$args
) =
@_
;
my
@allowed_packages
=
qw/Data::Dumper File::Find FindBin Log::Log4perl/
;
if
(
my
$this_policies_arg
=
$args
->{prohibit_package_vars}) {
if
(
my
$add_packages
=
$this_policies_arg
->{add_packages}) {
push
@allowed_packages
,
split
/\s+/,
$add_packages
;
}
}
my
@violations
;
for
(
my
$i
= 0,
my
$token_type
,
my
$token_data
;
my
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
$token_data
=
$token
->{data};
if
(
$token_type
== OUR_DECL) {
$token
=
$tokens
->[++
$i
];
$token_type
=
$token
->{type};
if
(
$token_type
== LEFT_PAREN) {
my
$violation
;
my
$left_paren_num
= 1;
for
(
$i
++;
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
if
(
$token_type
== LEFT_PAREN) {
$left_paren_num
++;
}
elsif
(
$token_type
== RIGHT_PAREN) {
if
(--
$left_paren_num
<= 0) {
if
(
$violation
) {
push
@violations
,
$violation
;
undef
$violation
;
}
last
;
}
}
elsif
(
$token_type
== GLOBAL_VAR ||
$token_type
== GLOBAL_ARRAY_VAR ||
$token_type
== GLOBAL_HASH_VAR ||
$token_type
== VAR ||
$token_type
== ARRAY_VAR ||
$token_type
== HASH_VAR
) {
if
(
$token
->{data} !~ /\A.[A-Z0-9_]+\Z/) {
$violation
||= +{
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
}
}
elsif
(
$token_type
== GLOBAL_VAR ||
$token_type
== GLOBAL_ARRAY_VAR ||
$token_type
== GLOBAL_HASH_VAR ||
$token_type
== VAR ||
$token_type
== ARRAY_VAR ||
$token_type
== HASH_VAR
) {
if
(
$token
->{data} !~ /\A.[A-Z0-9_]+\Z/) {
push
@violations
, {
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
}
elsif
(
$token_type
== LOCAL_DECL) {
$token
=
$tokens
->[++
$i
];
$token_type
=
$token
->{type};
if
(
$token_type
== LEFT_PAREN) {
my
$violation
;
my
$left_paren_num
= 1;
my
$does_exist_namespace_resolver
= 0;
my
@namespaces
;
my
@packages
;
my
@var_names
;
for
(
$i
++;
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
if
(
$token_type
== LEFT_PAREN) {
$left_paren_num
++;
}
elsif
(
$token_type
== RIGHT_PAREN) {
push
@var_names
,
pop
@namespaces
;
push
@packages
,
join
'::'
,
@namespaces
;
if
(--
$left_paren_num
<= 0) {
last
;
}
@namespaces
= ();
}
elsif
(
$token_type
== COMMA) {
push
@var_names
,
pop
@namespaces
;
push
@packages
,
join
'::'
,
@namespaces
;
@namespaces
= ();
}
elsif
(
$token_type
== NAMESPACE_RESOLVER) {
$does_exist_namespace_resolver
= 1;
}
else
{
push
@namespaces
,
$token
->{data};
}
}
if
(
$does_exist_namespace_resolver
) {
$token
=
$tokens
->[++
$i
];
if
(
$token
->{type} == ASSIGN) {
my
$is_violated
= 0;
for
my
$package
(
@packages
) {
if
(!any {
$package
=~ /\A[\$\@\%]
$_
/}
@allowed_packages
) {
$is_violated
= 1;
}
}
if
(
$is_violated
) {
push
@violations
, {
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
}
}
else
{
my
$does_exist_namespace_resolver
= 0;
my
$is_assigned
= 0;
my
@namespaces
= (
$token
->{data});
for
(
$i
++;
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
$token_data
=
$token
->{data};
if
(
$token_type
== NAMESPACE) {
push
@namespaces
,
$token_data
;
}
elsif
(
$token_type
== NAMESPACE_RESOLVER) {
$does_exist_namespace_resolver
= 1;
}
elsif
(
$token_type
== ASSIGN) {
$is_assigned
= 1;
last
;
}
elsif
(
$token_type
== SEMI_COLON) {
last
;
}
}
if
(
$does_exist_namespace_resolver
&&
$is_assigned
) {
pop
@namespaces
;
my
$package_name
=
join
'::'
,
@namespaces
;
if
(any {
$package_name
=~ /\A[\$\@\%]
$_
/}
@allowed_packages
) {
next
;
}
push
@violations
, {
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
}
elsif
(
$token_type
== GLOBAL_VAR ||
$token_type
== GLOBAL_ARRAY_VAR ||
$token_type
== GLOBAL_HASH_VAR ||
$token_type
== VAR ||
$token_type
== ARRAY_VAR ||
$token_type
== HASH_VAR
) {
my
@namespaces
= (
$token
->{data});
my
$does_exist_namespace_resolver
=
$tokens
->[
$i
+1]->{type} == NAMESPACE_RESOLVER ? 1 : 0;
for
(
$i
++;
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
if
(
$token_type
== ASSIGN ||
$token_type
== SEMI_COLON) {
last
;
}
elsif
(
$token_type
== NAMESPACE) {
push
@namespaces
,
$token
->{data};
}
}
if
(
$does_exist_namespace_resolver
) {
my
$var_name
=
pop
@namespaces
;
my
$package_name
=
join
'::'
,
@namespaces
;
if
(any {
$package_name
=~ /\A[\$\@\%]
$_
/}
@allowed_packages
) {
next
;
}
if
(
$var_name
!~ /\A.[A-Z0-9_]+\Z/) {
push
@violations
, {
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
}
elsif
(
$token_type
== SPECIFIC_VALUE &&
$token_data
eq
'$:'
) {
$token
=
$tokens
->[++
$i
];
my
$does_exist_namespace_resolver
=
$token
->{type} == COLON ? 1 : 0;
my
$var_token
;
for
(
$i
++;
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
if
(
$token_type
== ASSIGN) {
$var_token
=
$tokens
->[
$i
-1];
}
elsif
(
$token_type
== SEMI_COLON) {
last
;
}
}
if
(
$does_exist_namespace_resolver
&&
$var_token
->{data} !~ /\A.[A-Z0-9_]+\Z/) {
push
@violations
, {
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
elsif
(
$token_type
== USED_NAME &&
$token_data
eq
'vars'
) {
my
$is_used_package_var
= 0;
for
(
$i
++;
$token
=
$tokens
->[
$i
];
$i
++) {
$token_type
=
$token
->{type};
$token_data
=
$token
->{data};
if
(
$token_type
== REG_EXP) {
for
my
$elem
(
split
/\s+/,
$token_data
) {
if
(
$elem
=~ /\A[\$\@\%](.*)\Z/) {
if
($1 !~ /\A[A-Z0-9_]+\Z/) {
$is_used_package_var
= 1;
}
}
}
}
elsif
(
$token_type
== STRING ||
$token_type
== RAW_STRING) {
if
(
$token_data
=~ /\A[\$\@\%](.*)\Z/) {
if
($1 !~ /\A[A-Z0-9_]+\Z/) {
$is_used_package_var
= 1;
}
}
}
elsif
(
$token_type
== SEMI_COLON) {
last
;
}
}
if
(
$is_used_package_var
) {
push
@violations
, {
filename
=>
$file
,
line
=>
$token
->{line},
description
=> DESC,
explanation
=> EXPL,
policy
=> __PACKAGE__,
};
}
}
}
return
\
@violations
;
}
1;