1package Perl::Critic::Policy::Variables::ProhibitEvilVariables; 2 3use 5.006001; 4use strict; 5use warnings; 6 7use English qw(-no_match_vars); 8use Readonly; 9 10use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue 11 qw{ throw_policy_value }; 12use Perl::Critic::Utils qw{ 13 :characters :severities :data_conversion 14}; 15use Perl::Critic::Utils::DataConversion qw{ dor }; 16 17use base 'Perl::Critic::Policy'; 18 19our $VERSION = '1.140'; 20 21#----------------------------------------------------------------------------- 22 23Readonly::Scalar my $EXPL => q{Find an alternative variable}; 24 25Readonly::Hash my %SUBSCRIPTED_TYPE => hashify(qw{@ %}); 26 27Readonly::Scalar my $VARIABLE_NAME_REGEX => qr< [\$\@%] \S+ >xms; 28Readonly::Scalar my $REGULAR_EXPRESSION_REGEX => 29 qr< [/] ( [^/]+ ) [/] >xms; 30Readonly::Array my @DESCRIPTION_REGEXES => 31 qr< [{] ( [^}]+ ) [}] >xms, 32 qr{ < ( [^>]+ ) > }xms, 33 qr{ [[] ( [^]]+ ) []] }xms, 34 qr{ [(] ( [^)]+ ) [)] }xms, 35; 36Readonly::Scalar my $DESCRIPTION_REGEX => 37 qr< @{[join '|', @DESCRIPTION_REGEXES]} >xms; 38 39# It's kind of unfortunate that I had to put capturing parentheses in the 40# component regexes above, because they're not visible here and so make 41# figuring out the positions of captures hard. Too bad we can't make the 42# minimum perl version 5.10. :] 43Readonly::Scalar my $VARIABLES_REGEX => 44 qr< 45 \A 46 \s* 47 (?: 48 ( $VARIABLE_NAME_REGEX ) 49 | $REGULAR_EXPRESSION_REGEX 50 ) 51 (?: \s* $DESCRIPTION_REGEX )? 52 \s* 53 >xms; 54 55Readonly::Scalar my $VARIABLES_FILE_LINE_REGEX => 56 qr< 57 \A 58 \s* 59 (?: 60 ( $VARIABLE_NAME_REGEX ) 61 | $REGULAR_EXPRESSION_REGEX 62 ) 63 \s* 64 ( \S (?: .* \S )? )? 65 \s* 66 \z 67 >xms; 68 69# Indexes in the arrays of regexes for the "variables" option. 70Readonly::Scalar my $INDEX_REGEX => 0; 71Readonly::Scalar my $INDEX_DESCRIPTION => 1; 72 73#----------------------------------------------------------------------------- 74 75sub supported_parameters { 76 return ( 77 { 78 name => 'variables', 79 description => 'The names of or patterns for variables to forbid.', 80 default_string => $EMPTY, 81 parser => \&_parse_variables, 82 }, 83 { 84 name => 'variables_file', 85 description => 'A file containing names of or patterns for variables to forbid.', 86 default_string => $EMPTY, 87 parser => \&_parse_variables_file, 88 }, 89 ); 90} 91 92sub default_severity { return $SEVERITY_HIGHEST } 93sub default_themes { return qw( core bugs ) } 94sub applies_to { return qw{PPI::Token::Symbol} } 95 96#----------------------------------------------------------------------------- 97 98sub _parse_variables { 99 my ($self, $parameter, $config_string) = @_; 100 101 return if not $config_string; 102 return if $config_string =~ m< \A \s* \z >xms; 103 104 my $variable_specifications = $config_string; 105 106 while ( my ($variable, $regex_string, @descrs) = 107 $variable_specifications =~ m< $VARIABLES_REGEX >xms) { 108 109 substr $variable_specifications, 0, $LAST_MATCH_END[0], $EMPTY; 110 my $description = dor(@descrs); 111 112 $self->_handle_variable_specification( 113 variable => $variable, 114 regex_string => $regex_string, 115 description => $description, 116 option_name => 'variables', 117 option_value => $config_string, 118 ); 119 } 120 121 if ($variable_specifications) { 122 throw_policy_value 123 policy => $self->get_short_name(), 124 option_name => 'variables', 125 option_value => $config_string, 126 message_suffix => 127 qq{contains unparseable data: "$variable_specifications"}; 128 } 129 130 return; 131} 132 133sub _parse_variables_file { 134 my ($self, $parameter, $config_string) = @_; 135 136 return if not $config_string; 137 return if $config_string =~ m< \A \s* \z >xms; 138 139 open my $handle, '<', $config_string 140 or throw_policy_value 141 policy => $self->get_short_name(), 142 option_name => 'variables_file', 143 option_value => $config_string, 144 message_suffix => 145 qq<refers to a file that could not be opened: $OS_ERROR>; 146 while ( my $line = <$handle> ) { 147 $self->_handle_variable_specification_on_line($line, $config_string); 148 } 149 close $handle or warn qq<Could not close "$config_string": $OS_ERROR\n>; 150 151 return; 152} 153 154sub _handle_variable_specification_on_line { 155 my ($self, $line, $config_string) = @_; 156 157 $line =~ s< [#] .* \z ><>xms; 158 $line =~ s< \s+ \z ><>xms; 159 $line =~ s< \A \s+ ><>xms; 160 161 return if not $line; 162 163 if ( my ($variable, $regex_string, $description) = 164 $line =~ m< $VARIABLES_FILE_LINE_REGEX >xms) { 165 166 $self->_handle_variable_specification( 167 variable => $variable, 168 regex_string => $regex_string, 169 description => $description, 170 option_name => 'variables_file', 171 option_value => $config_string, 172 ); 173 } 174 else { 175 throw_policy_value 176 policy => $self->get_short_name(), 177 option_name => 'variables_file', 178 option_value => $config_string, 179 message_suffix => 180 qq{contains unparseable data: "$line"}; 181 } 182 183 return; 184} 185 186sub _handle_variable_specification { 187 my ($self, %arguments) = @_; 188 189 my $description = $arguments{description} || $EMPTY; 190 191 if ( my $regex_string = $arguments{regex_string} ) { 192 # These are variable name patterns (e.g. /acme/) 193 my $actual_regex; 194 195 eval { $actual_regex = qr/$regex_string/sm; ## no critic (ExtendedFormatting) 196 1 } 197 or throw_policy_value 198 policy => $self->get_short_name(), 199 option_name => $arguments{option_name}, 200 option_value => $arguments{option_value}, 201 message_suffix => 202 qq{contains an invalid regular expression: "$regex_string"}; 203 204 # Can't use a hash due to stringification, so this is an AoA. 205 push 206 @{ $self->{_evil_variables_regexes} ||= [] }, 207 [ $actual_regex, $description ]; 208 } 209 else { 210 # These are literal variable names (e.g. $[) 211 $self->{_evil_variables} ||= {}; 212 my $name = $arguments{variable}; 213 $self->{_evil_variables}{$name} = $description; 214 } 215 216 return; 217} 218 219#----------------------------------------------------------------------------- 220 221sub initialize_if_enabled { 222 my ($self, $config) = @_; 223 224 # Disable if no variables are specified; there's no point in running if 225 # there aren't any. 226 return 227 exists $self->{_evil_variables} 228 || exists $self->{_evil_variables_regexes}; 229} 230 231#----------------------------------------------------------------------------- 232 233sub violates { 234 my ( $self, $elem, undef ) = @_; 235 return if not $elem; 236 237 my @names = $self->_compute_symbol_names( $elem ) 238 or return; 239 240 my $evil_variables = $self->{_evil_variables}; 241 my $evil_variables_regexes = $self->{_evil_variables_regexes}; 242 243 foreach my $variable (@names) { 244 exists $evil_variables->{$variable} 245 and return $self->_make_violation( 246 $variable, 247 $evil_variables->{$variable}, 248 $elem, 249 ); 250 } 251 252 foreach my $variable (@names) { 253 foreach my $regex ( @{$evil_variables_regexes} ) { 254 $variable =~ $regex->[$INDEX_REGEX] 255 and return $self->_make_violation( 256 $variable, 257 $regex->[$INDEX_DESCRIPTION], 258 $elem, 259 ); 260 } 261 } 262 263 return; # ok! 264} 265 266#----------------------------------------------------------------------------- 267 268# We are unconditionally interested in the names of the symbol itself. If the 269# symbol is subscripted, we are interested in the subscripted form as well. 270 271sub _compute_symbol_names { 272 my ($self, $elem) = @_; 273 274 my @names; 275 276 my $name = $elem->symbol(); 277 push @names, $name; 278 279 if ($SUBSCRIPTED_TYPE{$elem->symbol_type()}) { 280 $name = $elem->content(); 281 my $next = $elem->snext_sibling(); 282 my @subscr; 283 while ($next and $next->isa('PPI::Structure::Subscript')) { 284 push @subscr, $next->content(); 285 $next = $next->snext_sibling(); 286 } 287 if (@subscr) { 288 push @names, join $EMPTY, $name, @subscr; 289 } 290 } 291 292 return @names; 293} 294 295#----------------------------------------------------------------------------- 296 297sub _make_violation { 298 my ($self, $variable, $description, $elem) = @_; 299 return $self->violation( 300 $description || qq<Prohibited variable "$variable" used>, 301 $EXPL, 302 $elem, 303 ); 304} 305 3061; 307 308__END__ 309 310#----------------------------------------------------------------------------- 311 312=pod 313 314=for stopwords subscripted 315 316=head1 NAME 317 318Perl::Critic::Policy::Variables::ProhibitEvilVariables - Ban variables that aren't blessed by your shop. 319 320 321=head1 AFFILIATION 322 323This Policy is part of the core L<Perl::Critic|Perl::Critic> 324distribution. 325 326 327=head1 DESCRIPTION 328 329Use this policy if you wish to prohibit the use of specific variables. These 330may be global variables warned against in C<perlvar>, or just variables whose 331names you do not like. 332 333 334=head1 CONFIGURATION 335 336The set of prohibited variables is configurable via the C<variables> and 337C<variables_file> options. 338 339The value of C<variables> should be a string of space-delimited, fully 340qualified variable names and/or regular expressions. An example of 341prohibiting two specific variables in a F<.perlcriticrc> file: 342 343 [Variables::ProhibitEvilVariables] 344 variables = $[ $^S $SIG{__DIE__} 345 346If you prohibit an array or hash (e.g. C<@INC>), use of elements of the array 347or hash will be prohibited as well. If you specify a subscripted variable (e.g. 348C<$SIG{__DIE__}>), only the literal subscript specified will be detected. The 349above <.perlcritic> file, for example, will cause C<perlcritic (1)> to detect 350C<$SIG{__DIE__} = \&foo>, but not 351 352 my $foo = '__DIE__'; 353 $SIG{$foo} = \&foo; 354 355Regular expressions are identified by values beginning and ending with 356slashes. Any variable with a name that matches C<m/pattern/sm> will be 357forbidden. For example: 358 359 [Variables::ProhibitEvilVariables] 360 variables = /acme/ 361 362would cause all variables that match C<m/acme/> to be forbidden. If 363you want a case-blind check, you can use (?i: ... ). For example 364 365 [Variables::ProhibitEvilVariables] 366 variables = /(?i:acme)/ 367 368forbids variables that match C<m/acme/smi>. 369 370In addition, you can override the default message ("Prohibited variable 371"I<variable>" used") with your own, in order to give suggestions for 372alternative action. To do so, put your message in curly braces after 373the variable name or regular expression. Like this: 374 375 [Variables::ProhibitEvilVariables] 376 variables = $[ {Found use of $[. Program to base index 0 instead} 377 378If your message contains curly braces, you can enclose it in parentheses, 379angle brackets, or square brackets instead. 380 381Similarly, the C<variables_file> option gives the name of a file 382containing specifications for prohibited variables. Only one variable 383specification is allowed per line and comments start with an octothorp 384and run to end of line; no curly braces are necessary for delimiting 385messages: 386 387 $[ # Prohibit the "$[" variable and use the default message. 388 389 # Prohibit the "$^S" variable and give a replacement message. 390 $^S Having to think about $^S in exception handlers is just wrong 391 392 # Use a regular expression. 393 /acme/ No coyotes allowed. 394 395By default, there are no prohibited variables, although I can think of a 396few that should be. See C<perldoc perlvar> for a few suggestions. 397 398 399=head1 RESTRICTIONS 400 401Variables of the form C<${^foo}> are not recognized by PPI as of version 4021.206. When PPI recognizes these, this policy will Just Work for them too. 403 404Only direct references to prohibited variables and literal subscripts will be 405recognized. For example, if you prohibit $[, the first line in 406 407 my $foo = \$[; 408 $$foo = 1; 409 410will be flagged as a violation, but not the second, even though the second, in 411fact, assigns to $[. Similarly, if you prohibit $SIG{__DIE__}, this policy 412will not recognize 413 414 my $foo = '__DIE__'; 415 $SIG{$foo} = sub {warn 'I cannot die!'}; 416 417as an assignment to $SIG{__DIE__}. 418 419 420=head1 NOTES 421 422This policy leans heavily on 423L<Perl::Critic::Policy::Modules::ProhibitEvilModules|Perl::Critic::Policy::Modules::ProhibitEvilModules> 424by Jeffrey Ryan Thalhammer. 425 426 427=head1 AUTHOR 428 429Thomas R. Wyant, III F<wyant at cpan dot org> 430 431 432=head1 COPYRIGHT 433 434Copyright (c) 2009-2011 Thomas R. Wyant, III 435 436This program is free software; you can redistribute it and/or modify 437it under the same terms as Perl itself. The full text of this license 438can be found in the LICENSE file included with this module. 439 440=cut 441 442# Local Variables: 443# mode: cperl 444# cperl-indent-level: 4 445# fill-column: 78 446# indent-tabs-mode: nil 447# c-indentation-style: bsd 448# End: 449# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : 450