line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Perl::Critic::Document; |
2
|
|
|
|
|
|
|
|
3
|
40
|
|
|
40
|
|
2106
|
use 5.010001; |
|
40
|
|
|
|
|
173
|
|
4
|
40
|
|
|
40
|
|
291
|
use strict; |
|
40
|
|
|
|
|
150
|
|
|
40
|
|
|
|
|
863
|
|
5
|
40
|
|
|
40
|
|
233
|
use warnings; |
|
40
|
|
|
|
|
116
|
|
|
40
|
|
|
|
|
1340
|
|
6
|
|
|
|
|
|
|
|
7
|
40
|
|
|
40
|
|
296
|
use List::Util qw< reduce >; |
|
40
|
|
|
|
|
117
|
|
|
40
|
|
|
|
|
3060
|
|
8
|
40
|
|
|
40
|
|
335
|
use Scalar::Util qw< blessed refaddr weaken >; |
|
40
|
|
|
|
|
147
|
|
|
40
|
|
|
|
|
2528
|
|
9
|
40
|
|
|
40
|
|
805
|
use version; |
|
40
|
|
|
|
|
2122
|
|
|
40
|
|
|
|
|
426
|
|
10
|
|
|
|
|
|
|
|
11
|
40
|
|
|
40
|
|
4259
|
use PPI::Document; |
|
40
|
|
|
|
|
119418
|
|
|
40
|
|
|
|
|
1427
|
|
12
|
40
|
|
|
40
|
|
324
|
use PPI::Document::File; |
|
40
|
|
|
|
|
134
|
|
|
40
|
|
|
|
|
1969
|
|
13
|
40
|
|
|
40
|
|
873
|
use PPIx::Utils::Traversal qw< split_ppi_node_by_namespace >; |
|
40
|
|
|
|
|
4565
|
|
|
40
|
|
|
|
|
2499
|
|
14
|
|
|
|
|
|
|
|
15
|
40
|
|
|
40
|
|
18525
|
use Perl::Critic::Annotation; |
|
40
|
|
|
|
|
193
|
|
|
40
|
|
|
|
|
1652
|
|
16
|
40
|
|
|
40
|
|
16279
|
use Perl::Critic::Exception::Parse qw< throw_parse >; |
|
40
|
|
|
|
|
156
|
|
|
40
|
|
|
|
|
1095
|
|
17
|
40
|
|
|
40
|
|
2342
|
use Perl::Critic::Utils qw< :booleans :characters hashify shebang_line >; |
|
40
|
|
|
|
|
174
|
|
|
40
|
|
|
|
|
1957
|
|
18
|
|
|
|
|
|
|
|
19
|
40
|
|
|
40
|
|
9755
|
use PPIx::Regexp 0.010 qw< >; |
|
40
|
|
|
|
|
1279
|
|
|
40
|
|
|
|
|
117293
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our $VERSION = '1.150'; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
our $AUTOLOAD; |
28
|
|
|
|
|
|
|
sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking) |
29
|
714
|
|
|
714
|
|
35856
|
my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms; |
30
|
714
|
100
|
|
|
|
3529
|
return if $function_name eq 'DESTROY'; |
31
|
571
|
|
|
|
|
922
|
my $self = shift; |
32
|
571
|
|
|
|
|
2616
|
return $self->{_doc}->$function_name(@_); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
sub new { |
38
|
140
|
|
|
140
|
1
|
38990
|
my ($class, @args) = @_; |
39
|
|
|
|
|
|
|
|
40
|
140
|
|
|
|
|
355
|
my $self = bless {}, $class; |
41
|
|
|
|
|
|
|
|
42
|
140
|
|
|
|
|
470
|
$self->_init_common(); |
43
|
140
|
|
|
|
|
475
|
$self->_init_from_external_source(@args); |
44
|
|
|
|
|
|
|
|
45
|
140
|
|
|
|
|
560
|
return $self; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
sub _new_for_parent_document { |
51
|
4
|
|
|
4
|
|
8
|
my ($class, $ppi_document, $parent_document) = @_; |
52
|
|
|
|
|
|
|
|
53
|
4
|
|
|
|
|
9
|
my $self = bless {}, $class; |
54
|
|
|
|
|
|
|
|
55
|
4
|
|
|
|
|
11
|
$self->_init_common(); |
56
|
|
|
|
|
|
|
|
57
|
4
|
|
|
|
|
8
|
$self->{_doc} = $ppi_document; |
58
|
4
|
|
|
|
|
10
|
$self->{_is_module} = $parent_document->is_module(); |
59
|
|
|
|
|
|
|
|
60
|
4
|
|
|
|
|
17
|
return $self; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub _init_common { |
66
|
144
|
|
|
144
|
|
309
|
my ($self) = @_; |
67
|
|
|
|
|
|
|
|
68
|
144
|
|
|
|
|
402
|
$self->{_annotations} = []; |
69
|
144
|
|
|
|
|
336
|
$self->{_suppressed_violations} = []; |
70
|
144
|
|
|
|
|
310
|
$self->{_disabled_line_map} = {}; |
71
|
|
|
|
|
|
|
|
72
|
144
|
|
|
|
|
302
|
return; |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub _init_from_external_source { ## no critic (Subroutines::RequireArgUnpacking) |
78
|
140
|
|
|
140
|
|
256
|
my $self = shift; |
79
|
140
|
|
|
|
|
236
|
my %args; |
80
|
|
|
|
|
|
|
|
81
|
140
|
50
|
|
|
|
424
|
if (@_ == 1) { |
82
|
0
|
|
|
|
|
0
|
warnings::warnif( |
83
|
|
|
|
|
|
|
'deprecated', |
84
|
|
|
|
|
|
|
'Perl::Critic::Document->new($source) deprecated, use Perl::Critic::Document->new(-source => $source) instead.' ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) |
85
|
|
|
|
|
|
|
); |
86
|
0
|
|
|
|
|
0
|
%args = ('-source' => shift); |
87
|
|
|
|
|
|
|
} else { |
88
|
140
|
|
|
|
|
466
|
%args = @_; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
140
|
|
|
|
|
295
|
my $source_code = $args{'-source'}; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# $source_code can be a file name, or a reference to a |
94
|
|
|
|
|
|
|
# PPI::Document, or a reference to a scalar containing source |
95
|
|
|
|
|
|
|
# code. In the last case, PPI handles the translation for us. |
96
|
|
|
|
|
|
|
|
97
|
140
|
100
|
|
|
|
388
|
my $ppi_document = |
|
|
100
|
|
|
|
|
|
98
|
|
|
|
|
|
|
_is_ppi_doc($source_code) |
99
|
|
|
|
|
|
|
? $source_code |
100
|
|
|
|
|
|
|
: ref $source_code |
101
|
|
|
|
|
|
|
? PPI::Document->new($source_code) |
102
|
|
|
|
|
|
|
: PPI::Document::File->new($source_code); |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Bail on error |
105
|
140
|
50
|
|
|
|
553086
|
if (not defined $ppi_document) { |
106
|
0
|
|
|
|
|
0
|
my $errstr = PPI::Document::errstr(); |
107
|
0
|
0
|
|
|
|
0
|
my $file = ref $source_code ? undef : $source_code; |
108
|
0
|
|
|
|
|
0
|
throw_parse |
109
|
|
|
|
|
|
|
message => qq<Can't parse code: $errstr>, |
110
|
|
|
|
|
|
|
file_name => $file; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
140
|
|
|
|
|
394
|
$self->{_doc} = $ppi_document; |
114
|
140
|
|
|
|
|
1130
|
$self->index_locations(); |
115
|
140
|
|
|
|
|
122418
|
$self->_disable_shebang_fix(); |
116
|
140
|
|
|
|
|
524
|
$self->{_filename_override} = $args{'-filename-override'}; |
117
|
140
|
|
|
|
|
487
|
$self->{_is_module} = $self->_determine_is_module(\%args); |
118
|
|
|
|
|
|
|
|
119
|
140
|
|
|
|
|
423
|
return; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
sub _is_ppi_doc { |
125
|
140
|
|
|
140
|
|
268
|
my ($ref) = @_; |
126
|
140
|
|
66
|
|
|
1550
|
return blessed($ref) && $ref->isa('PPI::Document'); |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub ppi_document { |
132
|
6
|
|
|
6
|
1
|
35
|
my ($self) = @_; |
133
|
6
|
|
|
|
|
20
|
return $self->{_doc}; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub isa { ## no critic ( Subroutines::ProhibitBuiltinHomonyms ) |
139
|
10
|
|
|
10
|
1
|
1207
|
my ($self, @args) = @_; |
140
|
|
|
|
|
|
|
return $self->SUPER::isa(@args) |
141
|
10
|
|
66
|
|
|
118
|
|| ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) ); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub find { |
147
|
6283
|
|
|
6283
|
1
|
11836
|
my ($self, $wanted, @more_args) = @_; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# This method can only find elements by their class names. For |
150
|
|
|
|
|
|
|
# other types of searches, delegate to the PPI::Document |
151
|
6283
|
100
|
100
|
|
|
28089
|
if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { |
|
|
|
100
|
|
|
|
|
152
|
75
|
|
|
|
|
297
|
return $self->{_doc}->find($wanted, @more_args); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# Build the class cache if it doesn't exist. This happens at most |
156
|
|
|
|
|
|
|
# once per Perl::Critic::Document instance. %elements of will be |
157
|
|
|
|
|
|
|
# populated as a side-effect of calling the $finder_sub coderef |
158
|
|
|
|
|
|
|
# that is produced by the caching_finder() closure. |
159
|
6208
|
100
|
|
|
|
11084
|
if ( !$self->{_elements_of} ) { |
160
|
|
|
|
|
|
|
|
161
|
98
|
|
|
|
|
413
|
my %cache = ( 'PPI::Document' => [ $self ] ); |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# The cache refers to $self, and $self refers to the cache. This |
164
|
|
|
|
|
|
|
# creates a circular reference that leaks memory (i.e. $self is not |
165
|
|
|
|
|
|
|
# destroyed until execution is complete). By weakening the reference, |
166
|
|
|
|
|
|
|
# we allow perl to collect the garbage properly. |
167
|
98
|
|
|
|
|
478
|
weaken( $cache{'PPI::Document'}->[0] ); |
168
|
|
|
|
|
|
|
|
169
|
98
|
|
|
|
|
305
|
my $finder_coderef = _caching_finder( \%cache ); |
170
|
98
|
|
|
|
|
537
|
$self->{_doc}->find( $finder_coderef ); |
171
|
98
|
|
|
|
|
2356
|
$self->{_elements_of} = \%cache; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# find() must return false-but-defined on fail |
175
|
6208
|
|
100
|
|
|
23918
|
return $self->{_elements_of}->{$wanted} || q{}; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub find_first { |
181
|
202
|
|
|
202
|
1
|
3671
|
my ($self, $wanted, @more_args) = @_; |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
# This method can only find elements by their class names. For |
184
|
|
|
|
|
|
|
# other types of searches, delegate to the PPI::Document |
185
|
202
|
100
|
100
|
|
|
887
|
if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { |
|
|
|
100
|
|
|
|
|
186
|
133
|
|
|
|
|
476
|
return $self->{_doc}->find_first($wanted, @more_args); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
69
|
|
|
|
|
161
|
my $result = $self->find($wanted); |
190
|
69
|
100
|
|
|
|
258
|
return $result ? $result->[0] : $result; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub find_any { |
196
|
4
|
|
|
4
|
1
|
2312
|
my ($self, $wanted, @more_args) = @_; |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# This method can only find elements by their class names. For |
199
|
|
|
|
|
|
|
# other types of searches, delegate to the PPI::Document |
200
|
4
|
100
|
100
|
|
|
32
|
if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { |
|
|
|
100
|
|
|
|
|
201
|
3
|
|
|
|
|
18
|
return $self->{_doc}->find_any($wanted, @more_args); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
1
|
|
|
|
|
5
|
my $result = $self->find($wanted); |
205
|
1
|
50
|
|
|
|
6
|
return $result ? 1 : $result; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
sub namespaces { |
211
|
2
|
|
|
2
|
1
|
410
|
my ($self) = @_; |
212
|
|
|
|
|
|
|
|
213
|
2
|
|
|
|
|
5
|
return keys %{ $self->_nodes_by_namespace() }; |
|
2
|
|
|
|
|
7
|
|
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub subdocuments_for_namespace { |
219
|
0
|
|
|
0
|
1
|
0
|
my ($self, $namespace) = @_; |
220
|
|
|
|
|
|
|
|
221
|
0
|
|
|
|
|
0
|
my $subdocuments = $self->_nodes_by_namespace()->{$namespace}; |
222
|
|
|
|
|
|
|
|
223
|
0
|
0
|
|
|
|
0
|
return $subdocuments ? @{$subdocuments} : (); |
|
0
|
|
|
|
|
0
|
|
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
sub ppix_regexp_from_element { |
229
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $element ) = @_; |
230
|
|
|
|
|
|
|
|
231
|
0
|
0
|
0
|
|
|
0
|
if ( blessed( $element ) && $element->isa( 'PPI::Element' ) ) { |
232
|
0
|
|
|
|
|
0
|
my $addr = refaddr( $element ); |
233
|
|
|
|
|
|
|
return $self->{_ppix_regexp_from_element}{$addr} |
234
|
0
|
0
|
|
|
|
0
|
if exists $self->{_ppix_regexp_from_element}{$addr}; |
235
|
0
|
|
|
|
|
0
|
return ( $self->{_ppix_regexp_from_element}{$addr} = |
236
|
|
|
|
|
|
|
PPIx::Regexp->new( $element, |
237
|
|
|
|
|
|
|
default_modifiers => |
238
|
|
|
|
|
|
|
$self->_find_use_re_modifiers_in_scope_from_element( |
239
|
|
|
|
|
|
|
$element ), |
240
|
|
|
|
|
|
|
) ); |
241
|
|
|
|
|
|
|
} else { |
242
|
0
|
|
|
|
|
0
|
return PPIx::Regexp->new( $element ); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
sub _find_use_re_modifiers_in_scope_from_element { |
247
|
0
|
|
|
0
|
|
0
|
my ( $self, $elem ) = @_; |
248
|
0
|
|
|
|
|
0
|
my @found; |
249
|
0
|
0
|
|
|
|
0
|
foreach my $use_re ( @{ $self->find( 'PPI::Statement::Include' ) || [] } ) |
|
0
|
|
|
|
|
0
|
|
250
|
|
|
|
|
|
|
{ |
251
|
0
|
0
|
|
|
|
0
|
're' eq $use_re->module() |
252
|
|
|
|
|
|
|
or next; |
253
|
0
|
0
|
|
|
|
0
|
$self->element_is_in_lexical_scope_after_statement_containing( |
254
|
|
|
|
|
|
|
$elem, $use_re ) |
255
|
|
|
|
|
|
|
or next; |
256
|
0
|
0
|
|
|
|
0
|
my $prefix = 'no' eq $use_re->type() ? q{-} : $EMPTY; |
257
|
|
|
|
|
|
|
push @found, |
258
|
0
|
|
|
|
|
0
|
map { "$prefix$_" } |
259
|
0
|
|
|
|
|
0
|
grep { m{ \A / }smx } |
260
|
|
|
|
|
|
|
map { |
261
|
0
|
0
|
|
|
|
0
|
$_->isa( 'PPI::Token::Quote' ) ? $_->string() : |
|
0
|
0
|
|
|
|
0
|
|
262
|
|
|
|
|
|
|
$_->isa( 'PPI::Token::QuoteLike::Words' ) ? $_->literal() : |
263
|
|
|
|
|
|
|
$_->content() } |
264
|
|
|
|
|
|
|
$use_re->schildren(); |
265
|
|
|
|
|
|
|
} |
266
|
0
|
|
|
|
|
0
|
return \@found; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# This got hung on the Perl::Critic::Document, rather than living in |
272
|
|
|
|
|
|
|
# Perl::Critic::Utils::PPI, because of the possibility that caching of scope |
273
|
|
|
|
|
|
|
# objects would turn out to be desirable. |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub element_is_in_lexical_scope_after_statement_containing { |
276
|
0
|
|
|
0
|
1
|
0
|
my ( $self, $inner_elem, $outer_elem ) = @_; |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
# If the outer element defines a scope, we're true if and only if |
279
|
|
|
|
|
|
|
# the outer element contains the inner element, and the inner |
280
|
|
|
|
|
|
|
# element is not somewhere that is hidden from the scope. |
281
|
0
|
0
|
|
|
|
0
|
if ( $outer_elem->scope() ) { |
282
|
0
|
|
|
|
|
0
|
return _inner_element_is_in_outer_scope_really( |
283
|
|
|
|
|
|
|
$inner_elem, $outer_elem ); |
284
|
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
# In the more general case: |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
# The last element of the statement containing the outer element |
289
|
|
|
|
|
|
|
# must be before the inner element. If not, we know we're false, |
290
|
|
|
|
|
|
|
# without walking the parse tree. |
291
|
|
|
|
|
|
|
|
292
|
0
|
0
|
|
|
|
0
|
my $stmt = $outer_elem->statement() |
293
|
|
|
|
|
|
|
or return; |
294
|
|
|
|
|
|
|
|
295
|
0
|
|
|
|
|
0
|
my $last_elem = $stmt; |
296
|
0
|
|
|
|
|
0
|
while ( $last_elem->isa( 'PPI::Node' ) ) { |
297
|
0
|
0
|
|
|
|
0
|
$last_elem = $last_elem->last_element() |
298
|
|
|
|
|
|
|
or return; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
0
|
0
|
|
|
|
0
|
my $stmt_loc = $last_elem->location() |
302
|
|
|
|
|
|
|
or return; |
303
|
|
|
|
|
|
|
|
304
|
0
|
0
|
|
|
|
0
|
my $inner_loc = $inner_elem->location() |
305
|
|
|
|
|
|
|
or return; |
306
|
|
|
|
|
|
|
|
307
|
0
|
0
|
|
|
|
0
|
$stmt_loc->[0] > $inner_loc->[0] |
308
|
|
|
|
|
|
|
and return; |
309
|
0
|
0
|
0
|
|
|
0
|
$stmt_loc->[0] == $inner_loc->[0] |
310
|
|
|
|
|
|
|
and $stmt_loc->[1] >= $inner_loc->[1] |
311
|
|
|
|
|
|
|
and return; |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# Since we know the inner element is after the outer element, find |
314
|
|
|
|
|
|
|
# the element that defines the scope of the statement that contains |
315
|
|
|
|
|
|
|
# the outer element. |
316
|
|
|
|
|
|
|
|
317
|
0
|
|
|
|
|
0
|
my $parent = $stmt; |
318
|
0
|
|
|
|
|
0
|
while ( ! $parent->scope() ) { |
319
|
|
|
|
|
|
|
# Things appearing in the right-hand side of a |
320
|
|
|
|
|
|
|
# PPI::Statement::Variable are not in-scope to its left-hand |
321
|
|
|
|
|
|
|
# side. RESTRICTION -- this code does not handle truly |
322
|
|
|
|
|
|
|
# pathological stuff like |
323
|
|
|
|
|
|
|
# my ( $c, $d ) = qw{ e f }; |
324
|
|
|
|
|
|
|
# my ( $a, $b ) = my ( $c, $d ) = ( $c, $d ); |
325
|
0
|
0
|
0
|
|
|
0
|
_inner_is_defined_by_outer( $inner_elem, $parent ) |
326
|
|
|
|
|
|
|
and _location_is_in_right_hand_side_of_assignment( |
327
|
|
|
|
|
|
|
$parent, $inner_elem ) |
328
|
|
|
|
|
|
|
and return; |
329
|
0
|
0
|
|
|
|
0
|
$parent = $parent->parent() |
330
|
|
|
|
|
|
|
or return; |
331
|
|
|
|
|
|
|
} |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# We're true if and only if the scope of the outer element contains |
334
|
|
|
|
|
|
|
# the inner element. |
335
|
|
|
|
|
|
|
|
336
|
0
|
|
|
|
|
0
|
return $inner_elem->descendant_of( $parent ); |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
# Helper for element_is_in_lexical_scope_after_statement_containing(). |
341
|
|
|
|
|
|
|
# Return true if and only if $outer_elem is a statement that defines |
342
|
|
|
|
|
|
|
# variables and $inner_elem is actually a variable defined in that |
343
|
|
|
|
|
|
|
# statement. |
344
|
|
|
|
|
|
|
sub _inner_is_defined_by_outer { |
345
|
0
|
|
|
0
|
|
0
|
my ( $inner_elem, $outer_elem ) = @_; |
346
|
0
|
0
|
0
|
|
|
0
|
$outer_elem->isa( 'PPI::Statement::Variable' ) |
347
|
|
|
|
|
|
|
and $inner_elem->isa( 'PPI::Token::Symbol' ) |
348
|
|
|
|
|
|
|
or return; |
349
|
0
|
|
|
|
|
0
|
my %defines = hashify( $outer_elem->variables() ); |
350
|
0
|
|
|
|
|
0
|
return $defines{$inner_elem->symbol()}; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# Helper for element_is_in_lexical_scope_after_statement_containing(). |
354
|
|
|
|
|
|
|
# Given that the outer element defines a scope, there are still things |
355
|
|
|
|
|
|
|
# that are lexically inside it but outside the scope. We return true if |
356
|
|
|
|
|
|
|
# and only if the inner element is inside the outer element, but not |
357
|
|
|
|
|
|
|
# inside one of the excluded elements. The cases handled so far: |
358
|
|
|
|
|
|
|
# for ----- the list is not part of the scope |
359
|
|
|
|
|
|
|
# foreach - the list is not part of the scope |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub _inner_element_is_in_outer_scope_really { |
362
|
0
|
|
|
0
|
|
0
|
my ( $inner_elem, $outer_elem ) = @_; |
363
|
0
|
0
|
|
|
|
0
|
$outer_elem->scope() |
364
|
|
|
|
|
|
|
or return; |
365
|
0
|
0
|
|
|
|
0
|
$inner_elem->descendant_of( $outer_elem ) |
366
|
|
|
|
|
|
|
or return; |
367
|
0
|
0
|
|
|
|
0
|
if ( $outer_elem->isa( 'PPI::Statement::Compound' ) ) { |
368
|
0
|
0
|
|
|
|
0
|
my $first = $outer_elem->schild( 0 ) |
369
|
|
|
|
|
|
|
or return; |
370
|
0
|
0
|
|
|
|
0
|
if ( { for => 1, foreach => 1 }->{ $first->content() } ) { |
371
|
0
|
|
|
|
|
0
|
my $next = $first; |
372
|
0
|
|
|
|
|
0
|
while ( $next = $next->snext_sibling() ) { |
373
|
0
|
0
|
|
|
|
0
|
$next->isa( 'PPI::Structure::List' ) |
374
|
|
|
|
|
|
|
or next; |
375
|
0
|
|
|
|
|
0
|
return ! $inner_elem->descendant_of( $next ); |
376
|
|
|
|
|
|
|
} |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
} |
379
|
0
|
|
|
|
|
0
|
return $TRUE; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# Helper for element_is_in_lexical_scope_after_statement_containing(). |
383
|
|
|
|
|
|
|
# Given and element that represents an assignment or assignment-ish |
384
|
|
|
|
|
|
|
# statement, and a location, return true if the location is to the right |
385
|
|
|
|
|
|
|
# of the equals sign, and false otherwise (including the case where |
386
|
|
|
|
|
|
|
# there is no equals sign). Only the leftmost equals is considered. This |
387
|
|
|
|
|
|
|
# is a restriction. |
388
|
|
|
|
|
|
|
sub _location_is_in_right_hand_side_of_assignment { |
389
|
0
|
|
|
0
|
|
0
|
my ( $elem, $inner_elem ) = @_; |
390
|
0
|
|
|
|
|
0
|
my $inner_loc = $inner_elem->location(); |
391
|
0
|
|
|
|
|
0
|
my $kid = $elem->schild( 0 ); |
392
|
0
|
|
|
|
|
0
|
while ( $kid ) { |
393
|
0
|
0
|
0
|
|
|
0
|
$kid->isa( 'PPI::Token::Operator' ) |
394
|
|
|
|
|
|
|
and q{=} eq $kid->content() |
395
|
|
|
|
|
|
|
or next; |
396
|
0
|
|
|
|
|
0
|
my $l = $kid->location(); |
397
|
0
|
0
|
|
|
|
0
|
$l->[0] > $inner_loc->[0] |
398
|
|
|
|
|
|
|
and return; |
399
|
0
|
0
|
0
|
|
|
0
|
$l->[0] == $inner_loc->[0] |
400
|
|
|
|
|
|
|
and $l->[1] >= $inner_loc->[1] |
401
|
|
|
|
|
|
|
and return; |
402
|
0
|
|
|
|
|
0
|
return $inner_elem->descendant_of( $elem ); |
403
|
|
|
|
|
|
|
} continue { |
404
|
0
|
|
|
|
|
0
|
$kid = $kid->snext_sibling(); |
405
|
|
|
|
|
|
|
} |
406
|
0
|
|
|
|
|
0
|
return; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
sub filename { |
412
|
232
|
|
|
232
|
1
|
1102
|
my ($self) = @_; |
413
|
|
|
|
|
|
|
|
414
|
232
|
100
|
|
|
|
625
|
if (defined $self->{_filename_override}) { |
415
|
2
|
|
|
|
|
12
|
return $self->{_filename_override}; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
else { |
418
|
230
|
|
|
|
|
422
|
my $doc = $self->{_doc}; |
419
|
230
|
50
|
|
|
|
1104
|
return $doc->can('filename') ? $doc->filename() : undef; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
sub highest_explicit_perl_version { |
426
|
134
|
|
|
134
|
1
|
272
|
my ($self) = @_; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
my $highest_explicit_perl_version = |
429
|
134
|
|
|
|
|
256
|
$self->{_highest_explicit_perl_version}; |
430
|
|
|
|
|
|
|
|
431
|
134
|
100
|
|
|
|
295
|
if ( not exists $self->{_highest_explicit_perl_version} ) { |
432
|
42
|
|
|
|
|
133
|
my $includes = $self->find( \&_is_a_version_statement ); |
433
|
|
|
|
|
|
|
|
434
|
42
|
100
|
|
|
|
581
|
if ($includes) { |
435
|
|
|
|
|
|
|
# Note: this doesn't use List::Util::max() because that function |
436
|
|
|
|
|
|
|
# doesn't use the overloaded ">=" etc of a version object. The |
437
|
|
|
|
|
|
|
# reduce() style lets version.pm take care of all comparing. |
438
|
|
|
|
|
|
|
# |
439
|
|
|
|
|
|
|
# For reference, max() ends up looking at the string converted to |
440
|
|
|
|
|
|
|
# an NV, or something like that. An underscore like "5.005_04" |
441
|
|
|
|
|
|
|
# provokes a warning and is chopped off at "5.005" thus losing the |
442
|
|
|
|
|
|
|
# minor part from the comparison. |
443
|
|
|
|
|
|
|
# |
444
|
|
|
|
|
|
|
# An underscore "5.005_04" is supposed to mean an alpha release |
445
|
|
|
|
|
|
|
# and shouldn't be used in a perl version. But it's shown in |
446
|
|
|
|
|
|
|
# perlfunc under "use" (as a number separator), and appears in |
447
|
|
|
|
|
|
|
# several modules supplied with perl 5.10.0 (like version.pm |
448
|
|
|
|
|
|
|
# itself!). At any rate if version.pm can understand it then |
449
|
|
|
|
|
|
|
# that's enough for here. |
450
|
|
|
|
|
|
|
$highest_explicit_perl_version = |
451
|
4
|
100
|
|
4
|
|
98
|
reduce { $a >= $b ? $a : $b } |
452
|
9
|
|
|
|
|
121
|
map { version->new( $_->version() ) } |
453
|
5
|
|
|
|
|
21
|
@{$includes}; |
|
5
|
|
|
|
|
12
|
|
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
else { |
456
|
37
|
|
|
|
|
83
|
$highest_explicit_perl_version = undef; |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
$self->{_highest_explicit_perl_version} = |
460
|
42
|
|
|
|
|
288
|
$highest_explicit_perl_version; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
134
|
100
|
|
|
|
352
|
return $highest_explicit_perl_version if $highest_explicit_perl_version; |
464
|
129
|
|
|
|
|
333
|
return; |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub uses_module { |
470
|
3
|
|
|
3
|
1
|
67
|
my ($self, $module_name) = @_; |
471
|
|
|
|
|
|
|
|
472
|
3
|
|
|
|
|
11
|
return exists $self->_modules_used()->{$module_name}; |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
sub process_annotations { |
478
|
81
|
|
|
81
|
1
|
180
|
my ($self) = @_; |
479
|
|
|
|
|
|
|
|
480
|
81
|
|
|
|
|
545
|
my @annotations = Perl::Critic::Annotation->create_annotations($self); |
481
|
81
|
|
|
|
|
308
|
$self->add_annotation(@annotations); |
482
|
81
|
|
|
|
|
198
|
return $self; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
sub line_is_disabled_for_policy { |
488
|
257
|
|
|
257
|
1
|
508
|
my ($self, $line, $policy) = @_; |
489
|
257
|
|
33
|
|
|
646
|
my $policy_name = ref $policy || $policy; |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# HACK: These two policies are special. If they are active, they cannot be |
492
|
|
|
|
|
|
|
# disabled by a "## no critic" annotation. Rather than create a general |
493
|
|
|
|
|
|
|
# hook in Policy.pm for enabling this behavior, we chose to hack |
494
|
|
|
|
|
|
|
# it here, since this isn't the kind of thing that most policies do. |
495
|
|
|
|
|
|
|
|
496
|
257
|
50
|
|
|
|
557
|
return 0 if $policy_name eq |
497
|
|
|
|
|
|
|
'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic'; |
498
|
257
|
50
|
|
|
|
446
|
return 0 if $policy_name eq |
499
|
|
|
|
|
|
|
'Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic'; |
500
|
|
|
|
|
|
|
|
501
|
257
|
100
|
|
|
|
932
|
return 1 if $self->{_disabled_line_map}->{$line}->{$policy_name}; |
502
|
189
|
100
|
|
|
|
528
|
return 1 if $self->{_disabled_line_map}->{$line}->{ALL}; |
503
|
150
|
|
|
|
|
381
|
return 0; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
sub add_annotation { |
509
|
81
|
|
|
81
|
1
|
207
|
my ($self, @annotations) = @_; |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# Add annotation to our private map for quick lookup |
512
|
81
|
|
|
|
|
189
|
for my $annotation (@annotations) { |
513
|
|
|
|
|
|
|
|
514
|
59
|
|
|
|
|
141
|
my ($start, $end) = $annotation->effective_range(); |
515
|
59
|
100
|
|
|
|
201
|
my @affected_policies = $annotation->disables_all_policies ? |
516
|
|
|
|
|
|
|
qw(ALL) : $annotation->disabled_policies(); |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
# TODO: Find clever way to do this with hash slices |
519
|
59
|
|
|
|
|
141
|
for my $line ($start .. $end) { |
520
|
165
|
|
|
|
|
217
|
for my $policy (@affected_policies) { |
521
|
1248
|
|
|
|
|
2139
|
$self->{_disabled_line_map}->{$line}->{$policy} = 1; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
} |
525
|
|
|
|
|
|
|
|
526
|
81
|
|
|
|
|
205
|
push @{ $self->{_annotations} }, @annotations; |
|
81
|
|
|
|
|
207
|
|
527
|
81
|
|
|
|
|
156
|
return $self; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
sub annotations { |
533
|
2
|
|
|
2
|
1
|
7
|
my ($self) = @_; |
534
|
2
|
|
|
|
|
5
|
return @{ $self->{_annotations} }; |
|
2
|
|
|
|
|
10
|
|
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
sub add_suppressed_violation { |
540
|
107
|
|
|
107
|
1
|
183
|
my ($self, $violation) = @_; |
541
|
107
|
|
|
|
|
161
|
push @{$self->{_suppressed_violations}}, $violation; |
|
107
|
|
|
|
|
203
|
|
542
|
107
|
|
|
|
|
177
|
return $self; |
543
|
|
|
|
|
|
|
} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
sub suppressed_violations { |
548
|
1
|
|
|
1
|
1
|
9
|
my ($self) = @_; |
549
|
1
|
|
|
|
|
2
|
return @{ $self->{_suppressed_violations} }; |
|
1
|
|
|
|
|
4
|
|
550
|
|
|
|
|
|
|
} |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
sub is_program { |
555
|
29
|
|
|
29
|
1
|
63
|
my ($self) = @_; |
556
|
|
|
|
|
|
|
|
557
|
29
|
|
|
|
|
75
|
return not $self->is_module(); |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
sub is_module { |
563
|
165
|
|
|
165
|
1
|
262
|
my ($self) = @_; |
564
|
|
|
|
|
|
|
|
565
|
165
|
|
|
|
|
501
|
return $self->{_is_module}; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
|
568
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
569
|
|
|
|
|
|
|
# PRIVATE functions & methods |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub _is_a_version_statement { |
572
|
2763
|
|
|
2763
|
|
21058
|
my (undef, $element) = @_; |
573
|
|
|
|
|
|
|
|
574
|
2763
|
100
|
|
|
|
6775
|
return 0 if not $element->isa('PPI::Statement::Include'); |
575
|
72
|
100
|
|
|
|
298
|
return 1 if $element->version(); |
576
|
63
|
|
|
|
|
1414
|
return 0; |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
sub _caching_finder { |
582
|
98
|
|
|
98
|
|
220
|
my $cache_ref = shift; |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
# These vars will persist for the life of the code ref that this sub returns. |
585
|
98
|
|
|
|
|
158
|
my %isa_cache; |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
# Gather up all the PPI elements and sort by @ISA. Note: if any |
588
|
|
|
|
|
|
|
# instances used multiple inheritance, this implementation would |
589
|
|
|
|
|
|
|
# lead to multiple copies of $element in the $elements_of lists. |
590
|
|
|
|
|
|
|
# However, PPI::* doesn't do multiple inheritance, so we are safe |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
return sub { |
593
|
4195
|
|
|
4195
|
|
37630
|
my (undef, $element) = @_; |
594
|
4195
|
|
|
|
|
6287
|
my $classes = $isa_cache{ref $element}; |
595
|
4195
|
100
|
|
|
|
6561
|
if ( !$classes ) { |
596
|
1123
|
|
|
|
|
2042
|
$classes = [ ref $element ]; |
597
|
|
|
|
|
|
|
# Use a C-style loop because we append to the classes array inside |
598
|
1123
|
|
|
|
|
1688
|
for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops) |
|
5029
|
|
|
|
|
8461
|
|
599
|
40
|
|
|
40
|
|
427
|
no strict 'refs'; ## no critic(ProhibitNoStrict) |
|
40
|
|
|
|
|
149
|
|
|
40
|
|
|
|
|
31247
|
|
600
|
3906
|
|
|
|
|
4330
|
push @{$classes}, @{"$classes->[$i]::ISA"}; |
|
3906
|
|
|
|
|
4682
|
|
|
3906
|
|
|
|
|
12863
|
|
601
|
3906
|
|
100
|
|
|
10162
|
$cache_ref->{$classes->[$i]} ||= []; |
602
|
|
|
|
|
|
|
} |
603
|
1123
|
|
|
|
|
2006
|
$isa_cache{$classes->[0]} = $classes; |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
4195
|
|
|
|
|
4632
|
for my $class ( @{$classes} ) { |
|
4195
|
|
|
|
|
5754
|
|
607
|
13480
|
|
|
|
|
14752
|
push @{$cache_ref->{$class}}, $element; |
|
13480
|
|
|
|
|
21753
|
|
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
4195
|
|
|
|
|
6571
|
return 0; # 0 tells find() to keep traversing, but not to store this $element |
611
|
98
|
|
|
|
|
643
|
}; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
sub _disable_shebang_fix { |
617
|
140
|
|
|
140
|
|
320
|
my ($self) = @_; |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
# When you install a program using ExtUtils::MakeMaker or Module::Build, it |
620
|
|
|
|
|
|
|
# inserts some magical code into the top of the file (just after the |
621
|
|
|
|
|
|
|
# shebang). This code allows people to call your program using a shell, |
622
|
|
|
|
|
|
|
# like `sh my_script`. Unfortunately, this code causes several Policy |
623
|
|
|
|
|
|
|
# violations, so we disable them as if they had "## no critic" annotations. |
624
|
|
|
|
|
|
|
|
625
|
140
|
|
100
|
|
|
790
|
my $first_stmnt = $self->schild(0) || return; |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
# Different versions of MakeMaker and Build use slightly different shebang |
628
|
|
|
|
|
|
|
# fixing strings. This matches most of the ones I've found in my own Perl |
629
|
|
|
|
|
|
|
# distribution, but it may not be bullet-proof. |
630
|
|
|
|
|
|
|
|
631
|
135
|
|
|
|
|
2833
|
my $fixin_rx = qr<^eval 'exec .* \$0 \$[{]1[+]"\$@"}'\s*[\r\n]\s*if.+;>ms; ## no critic (ExtendedFormatting) |
632
|
135
|
100
|
|
|
|
690
|
if ( $first_stmnt =~ $fixin_rx ) { |
633
|
1
|
|
|
|
|
57
|
my $line = $first_stmnt->location->[0]; |
634
|
1
|
|
|
|
|
39
|
$self->{_disabled_line_map}->{$line}->{ALL} = 1; |
635
|
1
|
|
|
|
|
6
|
$self->{_disabled_line_map}->{$line + 1}->{ALL} = 1; |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
|
638
|
135
|
|
|
|
|
4729
|
return $self; |
639
|
|
|
|
|
|
|
} |
640
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
sub _determine_is_module { |
644
|
140
|
|
|
140
|
|
369
|
my ($self, $args) = @_; |
645
|
|
|
|
|
|
|
|
646
|
140
|
|
|
|
|
422
|
my $file_name = $self->filename(); |
647
|
140
|
100
|
100
|
|
|
959
|
if ( |
648
|
|
|
|
|
|
|
defined $file_name |
649
|
|
|
|
|
|
|
and ref $args->{'-program-extensions'} eq 'ARRAY' |
650
|
|
|
|
|
|
|
) { |
651
|
27
|
|
|
|
|
37
|
foreach my $ext ( @{ $args->{'-program-extensions'} } ) { |
|
27
|
|
|
|
|
69
|
|
652
|
27
|
50
|
|
|
|
61
|
my $regex = |
653
|
|
|
|
|
|
|
ref $ext eq 'Regexp' |
654
|
|
|
|
|
|
|
? $ext |
655
|
0
|
|
|
|
|
0
|
: qr< @{ [ quotemeta $ext ] } \z >xms; |
656
|
|
|
|
|
|
|
|
657
|
27
|
50
|
|
|
|
128
|
return $FALSE if $file_name =~ m/$regex/smx; |
658
|
|
|
|
|
|
|
} |
659
|
|
|
|
|
|
|
} |
660
|
|
|
|
|
|
|
|
661
|
140
|
100
|
|
|
|
638
|
return $FALSE if shebang_line($self); |
662
|
137
|
100
|
100
|
|
|
505
|
return $FALSE if defined $file_name && $file_name =~ m/ [.] PL \z /smx; |
663
|
|
|
|
|
|
|
|
664
|
136
|
|
|
|
|
431
|
return $TRUE; |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
sub _nodes_by_namespace { |
670
|
2
|
|
|
2
|
|
4
|
my ($self) = @_; |
671
|
|
|
|
|
|
|
|
672
|
2
|
|
|
|
|
6
|
my $nodes = $self->{_nodes_by_namespace}; |
673
|
|
|
|
|
|
|
|
674
|
2
|
50
|
|
|
|
5
|
return $nodes if $nodes; |
675
|
|
|
|
|
|
|
|
676
|
2
|
|
|
|
|
8
|
my $ppi_document = $self->ppi_document(); |
677
|
2
|
50
|
|
|
|
9
|
if (not $ppi_document) { |
678
|
0
|
|
|
|
|
0
|
return $self->{_nodes_by_namespace} = {}; |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
|
681
|
2
|
|
|
|
|
11
|
my $raw_nodes_map = split_ppi_node_by_namespace($ppi_document); |
682
|
|
|
|
|
|
|
|
683
|
2
|
|
|
|
|
2174
|
my %wrapped_nodes; |
684
|
2
|
|
|
|
|
5
|
while ( my ($namespace, $raw_nodes) = each %{$raw_nodes_map} ) { |
|
6
|
|
|
|
|
25
|
|
685
|
|
|
|
|
|
|
$wrapped_nodes{$namespace} = [ |
686
|
4
|
|
|
|
|
13
|
map { __PACKAGE__->_new_for_parent_document($_, $self) } |
687
|
4
|
|
|
|
|
9
|
@{$raw_nodes} |
|
4
|
|
|
|
|
7
|
|
688
|
|
|
|
|
|
|
]; |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
2
|
|
|
|
|
27
|
return $self->{_nodes_by_namespace} = \%wrapped_nodes; |
692
|
|
|
|
|
|
|
} |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
# Note: must use exists on return value to determine membership because all |
697
|
|
|
|
|
|
|
# the values are false, unlike the result of hashify(). |
698
|
|
|
|
|
|
|
sub _modules_used { |
699
|
3
|
|
|
3
|
|
5
|
my ($self) = @_; |
700
|
|
|
|
|
|
|
|
701
|
3
|
|
|
|
|
8
|
my $mapping = $self->{_modules_used}; |
702
|
|
|
|
|
|
|
|
703
|
3
|
100
|
|
|
|
16
|
return $mapping if $mapping; |
704
|
|
|
|
|
|
|
|
705
|
2
|
|
|
|
|
6
|
my $includes = $self->find('PPI::Statement::Include'); |
706
|
2
|
100
|
|
|
|
7
|
if (not $includes) { |
707
|
1
|
|
|
|
|
10
|
return $self->{_modules_used} = {}; |
708
|
|
|
|
|
|
|
} |
709
|
|
|
|
|
|
|
|
710
|
1
|
|
|
|
|
2
|
my %mapping; |
711
|
1
|
|
|
|
|
3
|
for my $module ( |
712
|
1
|
50
|
|
|
|
40
|
grep { $_ } map { $_->module() || $_->pragma() } @{$includes} |
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
3
|
|
713
|
|
|
|
|
|
|
) { |
714
|
|
|
|
|
|
|
# Significantly less memory than $h{$k} => 1. Thanks Mr. Lembark. |
715
|
1
|
|
|
|
|
5
|
$mapping{$module} = (); |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
|
718
|
1
|
|
|
|
|
11
|
return $self->{_modules_used} = \%mapping; |
719
|
|
|
|
|
|
|
} |
720
|
|
|
|
|
|
|
|
721
|
|
|
|
|
|
|
#----------------------------------------------------------------------------- |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
1; |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
__END__ |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
=pod |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=for stopwords pre-caches |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
=head1 NAME |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
Perl::Critic::Document - Caching wrapper around a PPI::Document. |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
=head1 SYNOPSIS |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
use PPI::Document; |
739
|
|
|
|
|
|
|
use Perl::Critic::Document; |
740
|
|
|
|
|
|
|
my $doc = PPI::Document->new('Foo.pm'); |
741
|
|
|
|
|
|
|
$doc = Perl::Critic::Document->new(-source => $doc); |
742
|
|
|
|
|
|
|
## Then use the instance just like a PPI::Document |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
=head1 DESCRIPTION |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
Perl::Critic does a lot of iterations over the PPI document tree via |
748
|
|
|
|
|
|
|
the C<PPI::Document::find()> method. To save some time, this class |
749
|
|
|
|
|
|
|
pre-caches a lot of the common C<find()> calls in a single traversal. |
750
|
|
|
|
|
|
|
Then, on subsequent requests we return the cached data. |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
This is implemented as a facade, where method calls are handed to the |
753
|
|
|
|
|
|
|
stored C<PPI::Document> instance. |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
=head1 CAVEATS |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
This facade does not implement the overloaded operators from |
759
|
|
|
|
|
|
|
L<PPI::Document|PPI::Document> (that is, the C<use overload ...> |
760
|
|
|
|
|
|
|
work). Therefore, users of this facade must not rely on that syntactic |
761
|
|
|
|
|
|
|
sugar. So, for example, instead of C<my $source = "$doc";> you should |
762
|
|
|
|
|
|
|
write C<< my $source = $doc->content(); >> |
763
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
Perhaps there is a CPAN module out there which implements a facade |
765
|
|
|
|
|
|
|
better than we do here? |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
=head1 INTERFACE SUPPORT |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
This is considered to be a public class. Any changes to its interface |
771
|
|
|
|
|
|
|
will go through a deprecation cycle. |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
=over |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
=item C<< new(-source => $source_code, '-filename-override' => $filename, '-program-extensions' => [program_extensions]) >> |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
Create a new instance referencing a PPI::Document instance. The |
781
|
|
|
|
|
|
|
C<$source_code> can be the name of a file, a reference to a scalar |
782
|
|
|
|
|
|
|
containing actual source code, or a L<PPI::Document|PPI::Document> or |
783
|
|
|
|
|
|
|
L<PPI::Document::File|PPI::Document::File>. |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
In the event that C<$source_code> is a reference to a scalar containing actual |
786
|
|
|
|
|
|
|
source code or a L<PPI::Document|PPI::Document>, the resulting |
787
|
|
|
|
|
|
|
L<Perl::Critic::Document|Perl::Critic::Document> will not have a filename. |
788
|
|
|
|
|
|
|
This may cause L<Perl::Critic::Document|Perl::Critic::Document> to incorrectly |
789
|
|
|
|
|
|
|
classify the source code as a module or script. To avoid this problem, you |
790
|
|
|
|
|
|
|
can optionally set the C<-filename-override> to force the |
791
|
|
|
|
|
|
|
L<Perl::Critic::Document|Perl::Critic::Document> to have a particular |
792
|
|
|
|
|
|
|
C<$filename>. Do not use this option if C<$source_code> is already the name |
793
|
|
|
|
|
|
|
of a file, or is a reference to a L<PPI::Document::File|PPI::Document::File>. |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
The '-program-extensions' argument is optional, and is a reference to a list |
796
|
|
|
|
|
|
|
of strings and/or regular expressions. The strings will be made into regular |
797
|
|
|
|
|
|
|
expressions matching the end of a file name, and any document whose file name |
798
|
|
|
|
|
|
|
matches one of the regular expressions will be considered a program. |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
If -program-extensions is not specified, or if it does not determine the |
801
|
|
|
|
|
|
|
document type, the document will be considered to be a program if the source |
802
|
|
|
|
|
|
|
has a shebang line or its file name (if any) matches C<< m/ [.] PL \z /smx >>. |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
=back |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
=head1 METHODS |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
=over |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
=item C<< ppi_document() >> |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
Accessor for the wrapped PPI::Document instance. Note that altering |
813
|
|
|
|
|
|
|
this instance in any way can cause unpredictable failures in |
814
|
|
|
|
|
|
|
Perl::Critic's subsequent analysis because some caches may fall out of |
815
|
|
|
|
|
|
|
date. |
816
|
|
|
|
|
|
|
|
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=item C<< find($wanted) >> |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
=item C<< find_first($wanted) >> |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
=item C<< find_any($wanted) >> |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
Caching wrappers around the PPI methods. If C<$wanted> is a simple PPI class |
825
|
|
|
|
|
|
|
name, then the cache is employed. Otherwise we forward the call to the |
826
|
|
|
|
|
|
|
corresponding method of the C<PPI::Document> instance. |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
=item C<< namespaces() >> |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
Returns a list of the namespaces (package names) in the document. |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
=item C<< subdocuments_for_namespace($namespace) >> |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
Returns a list of sub-documents containing the elements in the given |
837
|
|
|
|
|
|
|
namespace. For example, given that the current document is for the source |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
foo(); |
840
|
|
|
|
|
|
|
package Foo; |
841
|
|
|
|
|
|
|
package Bar; |
842
|
|
|
|
|
|
|
package Foo; |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
this method will return two L<Perl::Critic::Document|Perl::Critic::Document>s |
845
|
|
|
|
|
|
|
for a parameter of C<"Foo">. For more, see |
846
|
|
|
|
|
|
|
L<PPIx::Utils::Traversal/split_ppi_node_by_namespace>. |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
|
849
|
|
|
|
|
|
|
=item C<< ppix_regexp_from_element($element) >> |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
Caching wrapper around C<< PPIx::Regexp->new($element) >>. If |
852
|
|
|
|
|
|
|
C<$element> is a C<PPI::Element> the cache is employed, otherwise it |
853
|
|
|
|
|
|
|
just returns the results of C<< PPIx::Regexp->new() >>. In either case, |
854
|
|
|
|
|
|
|
it returns C<undef> unless the argument is something that |
855
|
|
|
|
|
|
|
L<PPIx::Regexp|PPIx::Regexp> actually understands. |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
=item C<< element_is_in_lexical_scope_after_statement_containing( $inner, $outer ) >> |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
Is the C<$inner> element in lexical scope after the statement containing |
860
|
|
|
|
|
|
|
the C<$outer> element? |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
In the case where C<$outer> is itself a scope-defining element, returns true |
863
|
|
|
|
|
|
|
if C<$outer> contains C<$inner>. In any other case, C<$inner> must be |
864
|
|
|
|
|
|
|
after the last element of the statement containing C<$outer>, and the |
865
|
|
|
|
|
|
|
innermost scope for C<$outer> also contains C<$inner>. |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
This is not the same as asking whether C<$inner> is visible from |
868
|
|
|
|
|
|
|
C<$outer>. |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
=item C<< filename() >> |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
Returns the filename for the source code if applicable |
874
|
|
|
|
|
|
|
(PPI::Document::File) or C<undef> otherwise (PPI::Document). |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
=item C<< isa( $classname ) >> |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
To be compatible with other modules that expect to get a |
880
|
|
|
|
|
|
|
PPI::Document, the Perl::Critic::Document class masquerades as the |
881
|
|
|
|
|
|
|
PPI::Document class. |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
=item C<< highest_explicit_perl_version() >> |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
Returns a L<version|version> object for the highest Perl version |
887
|
|
|
|
|
|
|
requirement declared in the document via a C<use> or C<require> |
888
|
|
|
|
|
|
|
statement. Returns nothing if there is no version statement. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
=item C<< uses_module($module_or_pragma_name) >> |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
Answers whether there is a C<use>, C<require>, or C<no> of the given name in |
894
|
|
|
|
|
|
|
this document. Note that there is no differentiation of modules vs. pragmata |
895
|
|
|
|
|
|
|
here. |
896
|
|
|
|
|
|
|
|
897
|
|
|
|
|
|
|
|
898
|
|
|
|
|
|
|
=item C<< process_annotations() >> |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
Causes this Document to scan itself and mark which lines & |
901
|
|
|
|
|
|
|
policies are disabled by the C<"## no critic"> annotations. |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
=item C<< line_is_disabled_for_policy($line, $policy_object) >> |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
Returns true if the given C<$policy_object> or C<$policy_name> has |
907
|
|
|
|
|
|
|
been disabled for at C<$line> in this Document. Otherwise, returns false. |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
=item C<< add_annotation( $annotation ) >> |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
Adds an C<$annotation> object to this Document. |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
=item C<< annotations() >> |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
Returns a list containing all the |
918
|
|
|
|
|
|
|
L<Perl::Critic::Annotation|Perl::Critic::Annotation>s that |
919
|
|
|
|
|
|
|
were found in this Document. |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
=item C<< add_suppressed_violation($violation) >> |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
Informs this Document that a C<$violation> was found but not reported |
925
|
|
|
|
|
|
|
because it fell on a line that had been suppressed by a C<"## no critic"> |
926
|
|
|
|
|
|
|
annotation. Returns C<$self>. |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
=item C<< suppressed_violations() >> |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
Returns a list of references to all the |
932
|
|
|
|
|
|
|
L<Perl::Critic::Violation|Perl::Critic::Violation>s |
933
|
|
|
|
|
|
|
that were found in this Document but were suppressed. |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
=item C<< is_program() >> |
937
|
|
|
|
|
|
|
|
938
|
|
|
|
|
|
|
Returns whether this document is considered to be a program. |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
=item C<< is_module() >> |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
Returns whether this document is considered to be a Perl module. |
944
|
|
|
|
|
|
|
|
945
|
|
|
|
|
|
|
=back |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=head1 AUTHOR |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
Chris Dolan <cdolan@cpan.org> |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
=head1 COPYRIGHT |
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
Copyright (c) 2006-2023 Chris Dolan. |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify |
956
|
|
|
|
|
|
|
it under the same terms as Perl itself. The full text of this license |
957
|
|
|
|
|
|
|
can be found in the LICENSE file included with this module. |
958
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
=cut |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
############################################################################## |
962
|
|
|
|
|
|
|
# Local Variables: |
963
|
|
|
|
|
|
|
# mode: cperl |
964
|
|
|
|
|
|
|
# cperl-indent-level: 4 |
965
|
|
|
|
|
|
|
# fill-column: 78 |
966
|
|
|
|
|
|
|
# indent-tabs-mode: nil |
967
|
|
|
|
|
|
|
# c-indentation-style: bsd |
968
|
|
|
|
|
|
|
# End: |
969
|
|
|
|
|
|
|
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : |