1package Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars; 2 3use 5.006001; 4use strict; 5use warnings; 6 7use Readonly; 8 9use Perl::Critic::Utils qw< :booleans :characters :severities >; 10use base 'Perl::Critic::Policy'; 11 12#----------------------------------------------------------------------------- 13 14our $VERSION = '1.140'; 15 16#----------------------------------------------------------------------------- 17 18Readonly::Scalar my $DESC => q<String *may* require interpolation>; 19Readonly::Scalar my $EXPL => [ 51 ]; 20 21#----------------------------------------------------------------------------- 22 23sub supported_parameters { 24 return ( 25 { 26 name => 'rcs_keywords', 27 description => 'RCS keywords to ignore in potential interpolation.', 28 default_string => $EMPTY, 29 behavior => 'string list', 30 }, 31 ); 32} 33 34sub default_severity { return $SEVERITY_LOWEST } 35sub default_themes { return qw(core pbp cosmetic) } 36 37sub applies_to { 38 return qw< PPI::Token::Quote::Single PPI::Token::Quote::Literal >; 39} 40 41#----------------------------------------------------------------------------- 42 43sub initialize_if_enabled { 44 my ($self, $config) = @_; 45 46 my $rcs_keywords = $self->{_rcs_keywords}; 47 my @rcs_keywords = keys %{$rcs_keywords}; 48 49 if (@rcs_keywords) { 50 my $rcs_regexes = [ map { qr/ \$ $_ [^\n\$]* \$ /xms } @rcs_keywords ]; 51 $self->{_rcs_regexes} = $rcs_regexes; 52 } 53 54 return $TRUE; 55} 56 57sub violates { 58 my ( $self, $elem, undef ) = @_; 59 60 # The string() method strips off the quotes 61 my $string = $elem->string(); 62 return if not _needs_interpolation($string); 63 return if _looks_like_email_address($string); 64 return if _looks_like_use_vars($elem); 65 66 my $rcs_regexes = $self->{_rcs_regexes}; 67 return if $rcs_regexes and _contains_rcs_variable($string, $rcs_regexes); 68 69 return $self->violation( $DESC, $EXPL, $elem ); 70} 71 72#----------------------------------------------------------------------------- 73 74sub _needs_interpolation { 75 my ($string) = @_; 76 77 return 78 # Contains a $ or @ not followed by "{}". 79 $string =~ m< [\$\@] (?! [{] [}] ) \S+ >xms 80 # Contains metachars 81 # Note that \1 ... are not documented (that I can find), but are 82 # treated the same way as \0 by S_scan_const in toke.c, at least 83 # for regular double-quotish strings. Not, obviously, where 84 # regexes are involved. 85 || $string =~ m< 86 (?: \A | [^\\] ) 87 (?: \\{2} )* 88 \\ [tnrfbae01234567xcNluLUEQ] 89 >xms; 90} 91 92#----------------------------------------------------------------------------- 93 94# Stolen from Email::Address, which is deprecated. Since we are not modifying 95# the original code at all, we are less stringent in being Critic-compliant. 96 97## no critic ( RegularExpressions::RequireDotMatchAnything ) 98## no critic ( RegularExpressions::RequireLineBoundaryMatching ) 99## no critic ( RegularExpressions::ProhibitEscapedMetacharacters ) 100 101my $CTL = q{\x00-\x1F\x7F}; ## no critic ( ValuesAndExpressions::RequireInterpolationOfMetachars ) 102my $special = q{()<>\\[\\]:;@\\\\,."}; ## no critic ( ValuesAndExpressions::RequireInterpolationOfMetachars ) 103 104my $text = qr/[^\x0A\x0D]/x; 105my $quoted_pair = qr/\\$text/x; 106my $ctext = qr/(?>[^()\\]+)/x; 107my $ccontent = qr/$ctext|$quoted_pair/x; 108my $comment = qr/\s*\((?:\s*$ccontent)*\s*\)\s*/x; 109my $cfws = qr/$comment|\s+/x; 110my $atext = qq/[^$CTL$special\\s]/; 111my $atom = qr/$cfws*$atext+$cfws*/x; 112my $dot_atom_text = qr/$atext+(?:\.$atext+)*/x; 113my $dot_atom = qr/$cfws*$dot_atom_text$cfws*/x; 114my $qtext = qr/[^\\"]/x; 115my $qcontent = qr/$qtext|$quoted_pair/x; 116my $quoted_string = qr/$cfws*"$qcontent*"$cfws*/x; 117my $local_part = qr/$dot_atom|$quoted_string/x; 118my $dtext = qr/[^\[\]\\]/x; 119my $dcontent = qr/$dtext|$quoted_pair/x; 120my $domain_literal = qr/$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*/x; 121my $domain = qr/$dot_atom|$domain_literal/x; 122my $addr_spec = qr/$local_part\@$domain/x; 123 124sub _looks_like_email_address { 125 my ($string) = @_; 126 127 return if index ($string, q<@>) < 0; 128 return if $string =~ m< \W \@ >xms; 129 return if $string =~ m< \A \@ \w+ \b >xms; 130 131 return $string =~ $addr_spec; 132} 133 134#----------------------------------------------------------------------------- 135 136sub _contains_rcs_variable { 137 my ($string, $rcs_regexes) = @_; 138 139 foreach my $regex ( @{$rcs_regexes} ) { 140 return $TRUE if $string =~ m/$regex/xms; 141 } 142 143 return; 144} 145 146#----------------------------------------------------------------------------- 147 148sub _looks_like_use_vars { 149 my ($elem) = @_; 150 151 my $statement = $elem; 152 while ( not $statement->isa('PPI::Statement::Include') ) { 153 $statement = $statement->parent() or return; 154 } 155 156 return if $statement->type() ne q<use>; 157 return $statement->module() eq q<vars>; 158} 159 1601; 161 162__END__ 163 164#----------------------------------------------------------------------------- 165 166=pod 167 168=for stopwords RCS 169 170=head1 NAME 171 172Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars - Warns that you might have used single quotes when you really wanted double-quotes. 173 174 175=head1 AFFILIATION 176 177This Policy is part of the core L<Perl::Critic|Perl::Critic> 178distribution. 179 180 181=head1 DESCRIPTION 182 183This policy warns you if you use single-quotes or C<q//> with a string 184that has unescaped metacharacters that may need interpolation. Its 185hard to know for sure if a string really should be interpolated 186without looking into the symbol table. This policy just makes an 187educated guess by looking for metacharacters and sigils which usually 188indicate that the string should be interpolated. 189 190 191=head2 Exceptions 192 193=over 194 195=item * 196 197Variable names to C<use vars>: 198 199 use vars '$x'; # ok 200 use vars ('$y', '$z'); # ok 201 use vars qw< $a $b >; # ok 202 203 204=item * 205 206Things that look like e-mail addresses: 207 208 print 'john@foo.com'; # ok 209 $address = 'suzy.bar@baz.net'; # ok 210 211=back 212 213 214=head1 CONFIGURATION 215 216The C<rcs_keywords> option allows you to stop this policy from complaining 217about things that look like RCS variables, for example, in deriving values for 218C<$VERSION> variables. 219 220For example, if you've got code like 221 222 our ($VERSION) = (q<$Revision$> =~ m/(\d+)/mx); 223 224You can specify 225 226 [ValuesAndExpressions::RequireInterpolationOfMetachars] 227 rcs_keywords = Revision 228 229in your F<.perlcriticrc> to provide an exemption. 230 231 232=head1 NOTES 233 234Perl's own C<warnings> pragma also warns you about this. 235 236 237=head1 SEE ALSO 238 239L<Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals|Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals> 240 241 242=head1 AUTHOR 243 244Jeffrey Ryan Thalhammer <jeff@imaginative-software.com> 245 246 247=head1 COPYRIGHT 248 249Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. 250 251This program is free software; you can redistribute it and/or modify 252it under the same terms as Perl itself. The full text of this license 253can be found in the LICENSE file included with this module. 254 255=cut 256 257# Local Variables: 258# mode: cperl 259# cperl-indent-level: 4 260# fill-column: 78 261# indent-tabs-mode: nil 262# c-indentation-style: bsd 263# End: 264# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : 265