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