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