Commit | Line | Data |
---|---|---|
6036a254 | 1 | ############################################################################## |
a73f4a71 JRT |
2 | # $URL$ |
3 | # $Date$ | |
4 | # $Author$ | |
5 | # $Revision$ | |
6036a254 | 6 | ############################################################################## |
5bf96118 CD |
7 | |
8 | package Perl::Critic::Document; | |
9 | ||
df6dee2b | 10 | use 5.006001; |
5bf96118 | 11 | use strict; |
58a9e587 | 12 | use warnings; |
267b39b4 | 13 | |
d5835ca8 | 14 | use Carp qw< confess >; |
2d2fd196 | 15 | |
81e74a91 | 16 | use List::Util qw< reduce >; |
f79ca4e8 | 17 | use Scalar::Util qw< blessed refaddr weaken >; |
267b39b4 | 18 | use version; |
5bf96118 | 19 | |
013aa3aa ES |
20 | use PPI::Document; |
21 | use PPI::Document::File; | |
22 | use PPIx::Utilities::Node qw< split_ppi_node_by_namespace >; | |
23 | ||
d5835ca8 | 24 | use Perl::Critic::Annotation; |
d533eee5 | 25 | use Perl::Critic::Exception::Parse qw< throw_parse >; |
48b61139 | 26 | use Perl::Critic::Utils qw< :booleans :characters shebang_line >; |
d5835ca8 | 27 | |
f79ca4e8 TW |
28 | use PPIx::Regexp 0.010 qw< >; |
29 | ||
6036a254 | 30 | #----------------------------------------------------------------------------- |
58a9e587 | 31 | |
e7bc8e2b | 32 | our $VERSION = '1.110'; |
5bf96118 | 33 | |
6036a254 | 34 | #----------------------------------------------------------------------------- |
5bf96118 CD |
35 | |
36 | our $AUTOLOAD; | |
937b8de0 | 37 | sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking) |
6e7d6c9f CD |
38 | my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms; |
39 | return if $function_name eq 'DESTROY'; | |
40 | my $self = shift; | |
41 | return $self->{_doc}->$function_name(@_); | |
5bf96118 CD |
42 | } |
43 | ||
6036a254 | 44 | #----------------------------------------------------------------------------- |
5bf96118 | 45 | |
58a9e587 | 46 | sub new { |
d5835ca8 | 47 | my ($class, @args) = @_; |
013aa3aa ES |
48 | |
49 | my $self = bless {}, $class; | |
50 | ||
51 | $self->_init_common(); | |
52 | $self->_init_from_external_source(@args); | |
53 | ||
54 | return $self; | |
55 | } | |
56 | ||
57 | #----------------------------------------------------------------------------- | |
58 | ||
59 | sub _new_for_parent_document { | |
60 | my ($class, $ppi_document, $parent_document) = @_; | |
61 | ||
937b8de0 | 62 | my $self = bless {}, $class; |
013aa3aa ES |
63 | |
64 | $self->_init_common(); | |
65 | ||
66 | $self->{_doc} = $ppi_document; | |
67 | $self->{_is_module} = $parent_document->is_module(); | |
68 | ||
69 | return $self; | |
d5835ca8 JRT |
70 | } |
71 | ||
72 | #----------------------------------------------------------------------------- | |
73 | ||
013aa3aa ES |
74 | sub _init_common { |
75 | my ($self) = @_; | |
76 | my %args; | |
77 | ||
78 | $self->{_annotations} = []; | |
79 | $self->{_suppressed_violations} = []; | |
80 | $self->{_disabled_line_map} = {}; | |
81 | ||
82 | return; | |
83 | } | |
84 | ||
85 | #----------------------------------------------------------------------------- | |
d5835ca8 | 86 | |
013aa3aa | 87 | sub _init_from_external_source { ## no critic (Subroutines::RequireArgUnpacking) |
d533eee5 ES |
88 | my $self = shift; |
89 | my %args; | |
013aa3aa | 90 | |
d533eee5 ES |
91 | if (@_ == 1) { |
92 | warnings::warnif( | |
93 | 'deprecated', | |
94 | 'Perl::Critic::Document->new($source) deprecated, use Perl::Critic::Document->new(-source => $source) instead.' ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) | |
95 | ); | |
96 | %args = ('-source' => shift); | |
97 | } else { | |
98 | %args = @_; | |
99 | } | |
013aa3aa | 100 | |
d533eee5 | 101 | my $source_code = $args{'-source'}; |
d5835ca8 JRT |
102 | |
103 | # $source_code can be a file name, or a reference to a | |
104 | # PPI::Document, or a reference to a scalar containing source | |
105 | # code. In the last case, PPI handles the translation for us. | |
106 | ||
013aa3aa ES |
107 | my $ppi_document = |
108 | _is_ppi_doc($source_code) | |
109 | ? $source_code | |
110 | : ref $source_code | |
111 | ? PPI::Document->new($source_code) | |
112 | : PPI::Document::File->new($source_code); | |
d5835ca8 JRT |
113 | |
114 | # Bail on error | |
013aa3aa | 115 | if (not defined $ppi_document) { |
d5835ca8 JRT |
116 | my $errstr = PPI::Document::errstr(); |
117 | my $file = ref $source_code ? undef : $source_code; | |
118 | throw_parse | |
119 | message => qq<Can't parse code: $errstr>, | |
120 | file_name => $file; | |
121 | } | |
122 | ||
013aa3aa | 123 | $self->{_doc} = $ppi_document; |
d5835ca8 JRT |
124 | $self->index_locations(); |
125 | $self->_disable_shebang_fix(); | |
515ac1b2 | 126 | $self->{_forced_filename} = $args{'-forced-filename'}; |
48b61139 | 127 | $self->{_is_module} = $self->_determine_is_module(\%args); |
d5835ca8 | 128 | |
013aa3aa | 129 | return; |
5bf96118 CD |
130 | } |
131 | ||
6036a254 | 132 | #----------------------------------------------------------------------------- |
58a9e587 | 133 | |
d5835ca8 JRT |
134 | sub _is_ppi_doc { |
135 | my ($ref) = @_; | |
136 | return blessed($ref) && $ref->isa('PPI::Document'); | |
137 | } | |
138 | ||
139 | #----------------------------------------------------------------------------- | |
140 | ||
2b6293b2 CD |
141 | sub ppi_document { |
142 | my ($self) = @_; | |
143 | return $self->{_doc}; | |
144 | } | |
145 | ||
146 | #----------------------------------------------------------------------------- | |
147 | ||
47e1ff34 | 148 | sub isa { |
6e7d6c9f CD |
149 | my ($self, @args) = @_; |
150 | return $self->SUPER::isa(@args) | |
151 | || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) ); | |
47e1ff34 CD |
152 | } |
153 | ||
6036a254 | 154 | #----------------------------------------------------------------------------- |
47e1ff34 | 155 | |
5bf96118 | 156 | sub find { |
6e7d6c9f | 157 | my ($self, $wanted, @more_args) = @_; |
5bf96118 | 158 | |
58a9e587 JRT |
159 | # This method can only find elements by their class names. For |
160 | # other types of searches, delegate to the PPI::Document | |
5bf96118 | 161 | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { |
6e7d6c9f | 162 | return $self->{_doc}->find($wanted, @more_args); |
5bf96118 | 163 | } |
58a9e587 JRT |
164 | |
165 | # Build the class cache if it doesn't exist. This happens at most | |
166 | # once per Perl::Critic::Document instance. %elements of will be | |
167 | # populated as a side-effect of calling the $finder_sub coderef | |
168 | # that is produced by the caching_finder() closure. | |
5bf96118 | 169 | if ( !$self->{_elements_of} ) { |
389109ec | 170 | |
58a9e587 | 171 | my %cache = ( 'PPI::Document' => [ $self ] ); |
389109ec JRT |
172 | |
173 | # The cache refers to $self, and $self refers to the cache. This | |
174 | # creates a circular reference that leaks memory (i.e. $self is not | |
175 | # destroyed until execution is complete). By weakening the reference, | |
176 | # we allow perl to collect the garbage properly. | |
177 | weaken( $cache{'PPI::Document'}->[0] ); | |
178 | ||
58a9e587 JRT |
179 | my $finder_coderef = _caching_finder( \%cache ); |
180 | $self->{_doc}->find( $finder_coderef ); | |
181 | $self->{_elements_of} = \%cache; | |
182 | } | |
183 | ||
184 | # find() must return false-but-defined on fail | |
185 | return $self->{_elements_of}->{$wanted} || q{}; | |
186 | } | |
187 | ||
6036a254 | 188 | #----------------------------------------------------------------------------- |
58a9e587 | 189 | |
fb21e21e | 190 | sub find_first { |
6e7d6c9f | 191 | my ($self, $wanted, @more_args) = @_; |
fb21e21e CD |
192 | |
193 | # This method can only find elements by their class names. For | |
194 | # other types of searches, delegate to the PPI::Document | |
195 | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | |
6e7d6c9f | 196 | return $self->{_doc}->find_first($wanted, @more_args); |
fb21e21e CD |
197 | } |
198 | ||
199 | my $result = $self->find($wanted); | |
200 | return $result ? $result->[0] : $result; | |
201 | } | |
202 | ||
6036a254 | 203 | #----------------------------------------------------------------------------- |
fb21e21e | 204 | |
f5eeac3b | 205 | sub find_any { |
6e7d6c9f | 206 | my ($self, $wanted, @more_args) = @_; |
f5eeac3b CD |
207 | |
208 | # This method can only find elements by their class names. For | |
209 | # other types of searches, delegate to the PPI::Document | |
210 | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | |
6e7d6c9f | 211 | return $self->{_doc}->find_any($wanted, @more_args); |
f5eeac3b CD |
212 | } |
213 | ||
214 | my $result = $self->find($wanted); | |
215 | return $result ? 1 : $result; | |
216 | } | |
217 | ||
6036a254 | 218 | #----------------------------------------------------------------------------- |
f5eeac3b | 219 | |
013aa3aa ES |
220 | sub namespaces { |
221 | my ($self) = @_; | |
222 | ||
223 | return keys %{ $self->_nodes_by_namespace() }; | |
224 | } | |
225 | ||
226 | #----------------------------------------------------------------------------- | |
227 | ||
228 | sub subdocuments_for_namespace { | |
229 | my ($self, $namespace) = @_; | |
230 | ||
231 | my $subdocuments = $self->_nodes_by_namespace()->{$namespace}; | |
232 | ||
233 | return $subdocuments ? @{$subdocuments} : (); | |
234 | } | |
235 | ||
236 | #----------------------------------------------------------------------------- | |
237 | ||
f79ca4e8 TW |
238 | sub ppix_regexp_from_element { |
239 | my ( $self, $element ) = @_; | |
240 | ||
241 | if ( blessed( $element ) && $element->isa( 'PPI::Element' ) ) { | |
242 | my $addr = refaddr( $element ); | |
243 | return $self->{_ppix_regexp_from_element}{$addr} | |
244 | if exists $self->{_ppix_regexp_from_element}{$addr}; | |
245 | return ( $self->{_ppix_regexp_from_element}{$addr} = | |
246 | PPIx::Regexp->new( $element ) ); | |
247 | } else { | |
248 | return PPIx::Regexp->new( $element ); | |
249 | } | |
250 | } | |
251 | ||
252 | #----------------------------------------------------------------------------- | |
253 | ||
60108aef CD |
254 | sub filename { |
255 | my ($self) = @_; | |
013aa3aa | 256 | |
515ac1b2 JRT |
257 | if ($self->{_forced_filename}) { |
258 | return $self->{_forced_filename}; | |
259 | } | |
260 | else { | |
261 | my $doc = $self->{_doc}; | |
262 | return $doc->can('filename') ? $doc->filename() : undef; | |
263 | } | |
60108aef CD |
264 | } |
265 | ||
6036a254 | 266 | #----------------------------------------------------------------------------- |
60108aef | 267 | |
267b39b4 ES |
268 | sub highest_explicit_perl_version { |
269 | my ($self) = @_; | |
270 | ||
271 | my $highest_explicit_perl_version = | |
272 | $self->{_highest_explicit_perl_version}; | |
273 | ||
274 | if ( not exists $self->{_highest_explicit_perl_version} ) { | |
275 | my $includes = $self->find( \&_is_a_version_statement ); | |
276 | ||
277 | if ($includes) { | |
81e74a91 ES |
278 | # Note: this doesn't use List::Util::max() because that function |
279 | # doesn't use the overloaded ">=" etc of a version object. The | |
280 | # reduce() style lets version.pm take care of all comparing. | |
df9f8d80 ES |
281 | # |
282 | # For reference, max() ends up looking at the string converted to | |
283 | # an NV, or something like that. An underscore like "5.005_04" | |
284 | # provokes a warning and is chopped off at "5.005" thus losing the | |
285 | # minor part from the comparison. | |
286 | # | |
287 | # An underscore "5.005_04" is supposed to mean an alpha release | |
81e74a91 ES |
288 | # and shouldn't be used in a perl version. But it's shown in |
289 | # perlfunc under "use" (as a number separator), and appears in | |
290 | # several modules supplied with perl 5.10.0 (like version.pm | |
291 | # itself!). At any rate if version.pm can understand it then | |
292 | # that's enough for here. | |
267b39b4 | 293 | $highest_explicit_perl_version = |
81e74a91 | 294 | reduce { $a >= $b ? $a : $b } |
901273dd ES |
295 | map { version->new( $_->version() ) } |
296 | @{$includes}; | |
267b39b4 ES |
297 | } |
298 | else { | |
299 | $highest_explicit_perl_version = undef; | |
300 | } | |
301 | ||
302 | $self->{_highest_explicit_perl_version} = | |
303 | $highest_explicit_perl_version; | |
304 | } | |
305 | ||
306 | return $highest_explicit_perl_version if $highest_explicit_perl_version; | |
307 | return; | |
308 | } | |
309 | ||
937b8de0 JRT |
310 | #----------------------------------------------------------------------------- |
311 | ||
76b854e4 ES |
312 | sub uses_module { |
313 | my ($self, $module_name) = @_; | |
314 | ||
315 | return exists $self->_modules_used()->{$module_name}; | |
316 | } | |
317 | ||
318 | #----------------------------------------------------------------------------- | |
319 | ||
d5835ca8 JRT |
320 | sub process_annotations { |
321 | my ($self) = @_; | |
937b8de0 | 322 | |
d5835ca8 JRT |
323 | my @annotations = Perl::Critic::Annotation->create_annotations($self); |
324 | $self->add_annotation(@annotations); | |
937b8de0 JRT |
325 | return $self; |
326 | } | |
327 | ||
328 | #----------------------------------------------------------------------------- | |
329 | ||
d5835ca8 JRT |
330 | sub line_is_disabled_for_policy { |
331 | my ($self, $line, $policy) = @_; | |
332 | my $policy_name = ref $policy || $policy; | |
2d2fd196 JRT |
333 | |
334 | # HACK: This Policy is special. If it is active, it cannot be | |
d1237298 | 335 | # disabled by a "## no critic" annotation. Rather than create a general |
2d2fd196 | 336 | # hook in Policy.pm for enabling this behavior, we chose to hack |
d5835ca8 | 337 | # it here, since this isn't the kind of thing that most policies do |
2f4b6b33 JRT |
338 | |
339 | return 0 if $policy_name eq | |
2d2fd196 JRT |
340 | 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic'; |
341 | ||
d5835ca8 JRT |
342 | return 1 if $self->{_disabled_line_map}->{$line}->{$policy_name}; |
343 | return 1 if $self->{_disabled_line_map}->{$line}->{ALL}; | |
937b8de0 JRT |
344 | return 0; |
345 | } | |
346 | ||
347 | #----------------------------------------------------------------------------- | |
348 | ||
d5835ca8 JRT |
349 | sub add_annotation { |
350 | my ($self, @annotations) = @_; | |
351 | ||
352 | # Add annotation to our private map for quick lookup | |
353 | for my $annotation (@annotations) { | |
354 | ||
355 | my ($start, $end) = $annotation->effective_range(); | |
356 | my @affected_policies = $annotation->disables_all_policies ? | |
357 | qw(ALL) : $annotation->disabled_policies(); | |
358 | ||
359 | # TODO: Find clever way to do this with hash slices | |
360 | for my $line ($start .. $end) { | |
361 | for my $policy (@affected_policies) { | |
362 | $self->{_disabled_line_map}->{$line}->{$policy} = 1; | |
363 | } | |
364 | } | |
365 | } | |
366 | ||
367 | push @{ $self->{_annotations} }, @annotations; | |
2d2fd196 JRT |
368 | return $self; |
369 | } | |
4880392e | 370 | |
2d2fd196 | 371 | #----------------------------------------------------------------------------- |
4880392e | 372 | |
d5835ca8 | 373 | sub annotations { |
2d2fd196 | 374 | my ($self) = @_; |
d5835ca8 JRT |
375 | return @{ $self->{_annotations} }; |
376 | } | |
4880392e | 377 | |
d5835ca8 | 378 | #----------------------------------------------------------------------------- |
4880392e | 379 | |
d5835ca8 JRT |
380 | sub add_suppressed_violation { |
381 | my ($self, $violation) = @_; | |
382 | push @{$self->{_suppressed_violations}}, $violation; | |
383 | return $self; | |
384 | } | |
4880392e | 385 | |
d5835ca8 | 386 | #----------------------------------------------------------------------------- |
2d2fd196 | 387 | |
d5835ca8 JRT |
388 | sub suppressed_violations { |
389 | my ($self) = @_; | |
390 | return @{ $self->{_suppressed_violations} }; | |
95ebf9b0 JRT |
391 | } |
392 | ||
393 | #----------------------------------------------------------------------------- | |
d533eee5 | 394 | |
1b936936 | 395 | sub is_program { |
d533eee5 | 396 | my ($self) = @_; |
48b61139 ES |
397 | |
398 | return not $self->is_module(); | |
d533eee5 ES |
399 | } |
400 | ||
401 | #----------------------------------------------------------------------------- | |
402 | ||
403 | sub is_module { | |
404 | my ($self) = @_; | |
48b61139 ES |
405 | |
406 | return $self->{_is_module}; | |
d533eee5 ES |
407 | } |
408 | ||
409 | #----------------------------------------------------------------------------- | |
d5835ca8 | 410 | # PRIVATE functions & methods |
95ebf9b0 | 411 | |
267b39b4 ES |
412 | sub _is_a_version_statement { |
413 | my (undef, $element) = @_; | |
414 | ||
415 | return 0 if not $element->isa('PPI::Statement::Include'); | |
416 | return 1 if $element->version(); | |
417 | return 0; | |
418 | } | |
419 | ||
420 | #----------------------------------------------------------------------------- | |
421 | ||
58a9e587 | 422 | sub _caching_finder { |
58a9e587 JRT |
423 | my $cache_ref = shift; # These vars will persist for the life |
424 | my %isa_cache = (); # of the code ref that this sub returns | |
425 | ||
426 | ||
427 | # Gather up all the PPI elements and sort by @ISA. Note: if any | |
428 | # instances used multiple inheritance, this implementation would | |
429 | # lead to multiple copies of $element in the $elements_of lists. | |
430 | # However, PPI::* doesn't do multiple inheritance, so we are safe | |
431 | ||
432 | return sub { | |
6e7d6c9f | 433 | my (undef, $element) = @_; |
58a9e587 JRT |
434 | my $classes = $isa_cache{ref $element}; |
435 | if ( !$classes ) { | |
436 | $classes = [ ref $element ]; | |
437 | # Use a C-style loop because we append to the classes array inside | |
438 | for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops) | |
439 | no strict 'refs'; ## no critic(ProhibitNoStrict) | |
440 | push @{$classes}, @{"$classes->[$i]::ISA"}; | |
441 | $cache_ref->{$classes->[$i]} ||= []; | |
5bf96118 | 442 | } |
58a9e587 JRT |
443 | $isa_cache{$classes->[0]} = $classes; |
444 | } | |
5bf96118 | 445 | |
58a9e587 JRT |
446 | for my $class ( @{$classes} ) { |
447 | push @{$cache_ref->{$class}}, $element; | |
448 | } | |
5bf96118 | 449 | |
58a9e587 JRT |
450 | return 0; # 0 tells find() to keep traversing, but not to store this $element |
451 | }; | |
5bf96118 CD |
452 | } |
453 | ||
6036a254 | 454 | #----------------------------------------------------------------------------- |
58a9e587 | 455 | |
d5835ca8 | 456 | sub _disable_shebang_fix { |
2d2fd196 JRT |
457 | my ($self) = @_; |
458 | ||
1b936936 | 459 | # When you install a program using ExtUtils::MakeMaker or Module::Build, it |
937b8de0 | 460 | # inserts some magical code into the top of the file (just after the |
1b936936 | 461 | # shebang). This code allows people to call your program using a shell, |
937b8de0 | 462 | # like `sh my_script`. Unfortunately, this code causes several Policy |
d1237298 | 463 | # violations, so we disable them as if they had "## no critic" annotations. |
937b8de0 | 464 | |
d5835ca8 | 465 | my $first_stmnt = $self->schild(0) || return; |
937b8de0 JRT |
466 | |
467 | # Different versions of MakeMaker and Build use slightly different shebang | |
468 | # fixing strings. This matches most of the ones I've found in my own Perl | |
469 | # distribution, but it may not be bullet-proof. | |
470 | ||
5d6f7fbc | 471 | my $fixin_rx = qr<^eval 'exec .* \$0 \${1[+]"\$@"}'\s*[\r\n]\s*if.+;>ms; ## no critic (ExtendedFormatting) |
937b8de0 | 472 | if ( $first_stmnt =~ $fixin_rx ) { |
d5835ca8 JRT |
473 | my $line = $first_stmnt->location->[0]; |
474 | $self->{_disabled_line_map}->{$line}->{ALL} = 1; | |
475 | $self->{_disabled_line_map}->{$line + 1}->{ALL} = 1; | |
937b8de0 JRT |
476 | } |
477 | ||
2d2fd196 | 478 | return $self; |
937b8de0 JRT |
479 | } |
480 | ||
481 | #----------------------------------------------------------------------------- | |
482 | ||
48b61139 | 483 | sub _determine_is_module { |
d533eee5 ES |
484 | my ($self, $args) = @_; |
485 | ||
486 | my $file_name = $self->filename(); | |
1b936936 ES |
487 | if ( |
488 | defined $file_name | |
489 | and ref $args->{'-program-extensions'} eq 'ARRAY' | |
490 | ) { | |
491 | foreach my $ext ( @{ $args->{'-program-extensions'} } ) { | |
492 | my $regex = | |
493 | ref $ext eq 'Regexp' | |
494 | ? $ext | |
495 | : qr< @{ [ quotemeta $ext ] } \z >xms; | |
496 | ||
48b61139 | 497 | return $FALSE if $file_name =~ m/$regex/smx; |
d533eee5 ES |
498 | } |
499 | } | |
500 | ||
48b61139 ES |
501 | return $FALSE if shebang_line($self); |
502 | return $FALSE if defined $file_name && $file_name =~ m/ [.] PL \z /smx; | |
d533eee5 | 503 | |
48b61139 | 504 | return $TRUE; |
d533eee5 ES |
505 | } |
506 | ||
507 | #----------------------------------------------------------------------------- | |
508 | ||
013aa3aa ES |
509 | sub _nodes_by_namespace { |
510 | my ($self) = @_; | |
511 | ||
512 | my $nodes = $self->{_nodes_by_namespace}; | |
513 | ||
514 | return $nodes if $nodes; | |
515 | ||
516 | my $ppi_document = $self->ppi_document(); | |
517 | if (not $ppi_document) { | |
518 | return $self->{_nodes_by_namespace} = {}; | |
519 | } | |
520 | ||
521 | my $raw_nodes_map = split_ppi_node_by_namespace($ppi_document); | |
522 | ||
523 | my %wrapped_nodes; | |
524 | while ( my ($namespace, $raw_nodes) = each %{$raw_nodes_map} ) { | |
ef89e7fc | 525 | $wrapped_nodes{$namespace} = [ |
013aa3aa | 526 | map { __PACKAGE__->_new_for_parent_document($_, $self) } |
ef89e7fc ES |
527 | @{$raw_nodes} |
528 | ]; | |
013aa3aa ES |
529 | } |
530 | ||
531 | return $self->{_nodes_by_namespace} = \%wrapped_nodes; | |
532 | } | |
533 | ||
534 | #----------------------------------------------------------------------------- | |
535 | ||
76b854e4 ES |
536 | # Note: must use exists on return value to determine membership because all |
537 | # the values are false, unlike the result of hashify(). | |
538 | sub _modules_used { | |
539 | my ($self) = @_; | |
540 | ||
541 | my $mapping = $self->{_modules_used}; | |
542 | ||
543 | return $mapping if $mapping; | |
544 | ||
545 | my $includes = $self->find('PPI::Statement::Include'); | |
2187a8d2 ES |
546 | if (not $includes) { |
547 | return $self->{_modules_used} = {}; | |
548 | } | |
76b854e4 ES |
549 | |
550 | my %mapping; | |
551 | for my $module ( | |
552 | grep { $_ } map { $_->module() || $_->pragma() } @{$includes} | |
553 | ) { | |
554 | # Significanly ess memory than $h{$k} => 1. Thanks Mr. Lembark. | |
555 | $mapping{$module} = (); | |
556 | } | |
557 | ||
558 | return $self->{_modules_used} = \%mapping; | |
559 | } | |
560 | ||
561 | #----------------------------------------------------------------------------- | |
562 | ||
5bf96118 | 563 | 1; |
58a9e587 | 564 | |
5bf96118 CD |
565 | __END__ |
566 | ||
a73f4a71 JRT |
567 | =pod |
568 | ||
569 | =for stopwords pre-caches | |
570 | ||
5bf96118 CD |
571 | =head1 NAME |
572 | ||
c728943a | 573 | Perl::Critic::Document - Caching wrapper around a PPI::Document. |
5bf96118 | 574 | |
267b39b4 | 575 | |
5bf96118 CD |
576 | =head1 SYNOPSIS |
577 | ||
578 | use PPI::Document; | |
579 | use Perl::Critic::Document; | |
580 | my $doc = PPI::Document->new('Foo.pm'); | |
d533eee5 | 581 | $doc = Perl::Critic::Document->new(-source => $doc); |
5bf96118 CD |
582 | ## Then use the instance just like a PPI::Document |
583 | ||
267b39b4 | 584 | |
5bf96118 CD |
585 | =head1 DESCRIPTION |
586 | ||
587 | Perl::Critic does a lot of iterations over the PPI document tree via | |
588 | the C<PPI::Document::find()> method. To save some time, this class | |
589 | pre-caches a lot of the common C<find()> calls in a single traversal. | |
590 | Then, on subsequent requests we return the cached data. | |
591 | ||
592 | This is implemented as a facade, where method calls are handed to the | |
593 | stored C<PPI::Document> instance. | |
594 | ||
267b39b4 | 595 | |
5bf96118 CD |
596 | =head1 CAVEATS |
597 | ||
598 | This facade does not implement the overloaded operators from | |
11f53956 ES |
599 | L<PPI::Document|PPI::Document> (that is, the C<use overload ...> |
600 | work). Therefore, users of this facade must not rely on that syntactic | |
601 | sugar. So, for example, instead of C<my $source = "$doc";> you should | |
602 | write C<my $source = $doc->content();> | |
5bf96118 CD |
603 | |
604 | Perhaps there is a CPAN module out there which implements a facade | |
605 | better than we do here? | |
606 | ||
267b39b4 | 607 | |
4444d94d ES |
608 | =head1 INTERFACE SUPPORT |
609 | ||
610 | This is considered to be a public class. Any changes to its interface | |
611 | will go through a deprecation cycle. | |
612 | ||
613 | ||
267b39b4 ES |
614 | =head1 CONSTRUCTOR |
615 | ||
616 | =over | |
617 | ||
515ac1b2 | 618 | =item C<< new(-source => $source_code, '-forced-filename' => $filename, '-program-extensions' => [program_extensions]) >> |
267b39b4 | 619 | |
d5835ca8 JRT |
620 | Create a new instance referencing a PPI::Document instance. The |
621 | C<$source_code> can be the name of a file, a reference to a scalar | |
0e4a0ae1 TW |
622 | containing actual source code, or a L<PPI::Document|PPI::Document> or |
623 | L<PPI::Document::File|PPI::Document::File>. | |
267b39b4 | 624 | |
515ac1b2 JRT |
625 | In the event that C<$source_code> is a reference to a scalar containing |
626 | actual source code or a L<PPI::Document|PPI::Document>, the resulting | |
627 | L<Perl::Critic::Document|Perl::Critic::Document> will not have a filename. | |
628 | This may cause L<Perl::Critic::Document|Perl::Critic::Document> to incorrectly | |
629 | classify the source code as a module or script. To avoid this problem, you | |
630 | can optionally set the C<-forced-filename> to force the L<Perl::Critic::Document|Perl::Critic::Document> | |
631 | to have a particular C<$filename>. Do not use this option if C<$source_code> | |
632 | is already the name of a file, or is a reference to a L<PPI::Document::File|PPI::Document::File>. | |
633 | ||
48b61139 ES |
634 | The '-program-extensions' argument is optional, and is a reference to a list |
635 | of strings and/or regular expressions. The strings will be made into regular | |
636 | expressions matching the end of a file name, and any document whose file name | |
637 | matches one of the regular expressions will be considered a program. | |
d533eee5 | 638 | |
1b936936 | 639 | If -program-extensions is not specified, or if it does not determine the |
48b61139 ES |
640 | document type, the document will be considered to be a program if the source |
641 | has a shebang line or its file name (if any) matches C<< m/ [.] PL \z /smx >>. | |
d533eee5 | 642 | |
267b39b4 ES |
643 | =back |
644 | ||
5bf96118 CD |
645 | =head1 METHODS |
646 | ||
647 | =over | |
648 | ||
267b39b4 | 649 | =item C<< ppi_document() >> |
2b6293b2 | 650 | |
11f53956 ES |
651 | Accessor for the wrapped PPI::Document instance. Note that altering |
652 | this instance in any way can cause unpredictable failures in | |
653 | Perl::Critic's subsequent analysis because some caches may fall out of | |
654 | date. | |
2b6293b2 | 655 | |
5bf96118 | 656 | |
267b39b4 ES |
657 | =item C<< find($wanted) >> |
658 | ||
659 | =item C<< find_first($wanted) >> | |
fb21e21e | 660 | |
267b39b4 | 661 | =item C<< find_any($wanted) >> |
f5eeac3b | 662 | |
76b854e4 ES |
663 | Caching wrappers around the PPI methods. If C<$wanted> is a simple PPI class |
664 | name, then the cache is employed. Otherwise we forward the call to the | |
665 | corresponding method of the C<PPI::Document> instance. | |
5bf96118 | 666 | |
267b39b4 | 667 | |
013aa3aa ES |
668 | =item C<< namespaces() >> |
669 | ||
670 | Returns a list of the namespaces (package names) in the document. | |
671 | ||
672 | ||
673 | =item C<< subdocuments_for_namespace($namespace) >> | |
674 | ||
675 | Returns a list of sub-documents containing the elements in the given | |
676 | namespace. For example, given that the current document is for the source | |
677 | ||
678 | foo(); | |
679 | package Foo; | |
680 | package Bar; | |
681 | package Foo; | |
682 | ||
683 | this method will return two L<Perl::Critic::Document|Perl::Critic::Document>s | |
684 | for a parameter of C<"Foo">. For more, see | |
685 | L<PPIx::Utilities::Node/split_ppi_node_by_namespace>. | |
686 | ||
687 | ||
f79ca4e8 TW |
688 | =item C<< ppix_regexp_from_element($element) >> |
689 | ||
690 | Caching wrapper around C<< PPIx::Regexp->new($element) >>. If | |
691 | C<$element> is a C<PPI::Element> the cache is employed, otherwise it | |
692 | just returns the results of C<< PPIx::Regexp->new() >>. In either case, | |
693 | it returns C<undef> unless the argument is something that | |
694 | L<PPIx::Regexp|PPIx::Regexp> actually understands. | |
695 | ||
696 | ||
267b39b4 | 697 | =item C<< filename() >> |
e7f2d995 CD |
698 | |
699 | Returns the filename for the source code if applicable | |
700 | (PPI::Document::File) or C<undef> otherwise (PPI::Document). | |
701 | ||
267b39b4 ES |
702 | |
703 | =item C<< isa( $classname ) >> | |
242f7b08 | 704 | |
11f53956 ES |
705 | To be compatible with other modules that expect to get a |
706 | PPI::Document, the Perl::Critic::Document class masquerades as the | |
707 | PPI::Document class. | |
242f7b08 | 708 | |
267b39b4 ES |
709 | |
710 | =item C<< highest_explicit_perl_version() >> | |
711 | ||
11f53956 ES |
712 | Returns a L<version|version> object for the highest Perl version |
713 | requirement declared in the document via a C<use> or C<require> | |
714 | statement. Returns nothing if there is no version statement. | |
267b39b4 | 715 | |
013aa3aa | 716 | |
76b854e4 ES |
717 | =item C<< uses_module($module_or_pragma_name) >> |
718 | ||
719 | Answers whether there is a C<use>, C<require>, or C<no> of the given name in | |
720 | this document. Note that there is no differentiation of modules vs. pragmata | |
721 | here. | |
722 | ||
723 | ||
d5835ca8 | 724 | =item C<< process_annotations() >> |
267b39b4 | 725 | |
d5835ca8 JRT |
726 | Causes this Document to scan itself and mark which lines & |
727 | policies are disabled by the C<"## no critic"> annotations. | |
937b8de0 | 728 | |
013aa3aa | 729 | |
d5835ca8 | 730 | =item C<< line_is_disabled_for_policy($line, $policy_object) >> |
937b8de0 | 731 | |
fcb2381b | 732 | Returns true if the given C<$policy_object> or C<$policy_name> has |
d5835ca8 | 733 | been disabled for at C<$line> in this Document. Otherwise, returns false. |
937b8de0 | 734 | |
013aa3aa | 735 | |
d5835ca8 | 736 | =item C<< add_annotation( $annotation ) >> |
937b8de0 | 737 | |
d5835ca8 | 738 | Adds an C<$annotation> object to this Document. |
2d2fd196 | 739 | |
013aa3aa | 740 | |
d5835ca8 | 741 | =item C<< annotations() >> |
2d2fd196 | 742 | |
0e4a0ae1 TW |
743 | Returns a list containing all the |
744 | L<Perl::Critic::Annotation|Perl::Critic::Annotation>s that | |
d5835ca8 | 745 | were found in this Document. |
2d2fd196 | 746 | |
013aa3aa | 747 | |
d5835ca8 | 748 | =item C<< add_suppressed_violation($violation) >> |
2d2fd196 | 749 | |
fcb2381b | 750 | Informs this Document that a C<$violation> was found but not reported |
d5835ca8 JRT |
751 | because it fell on a line that had been suppressed by a C<"## no critic"> |
752 | annotation. Returns C<$self>. | |
95ebf9b0 | 753 | |
013aa3aa | 754 | |
d5835ca8 | 755 | =item C<< suppressed_violations() >> |
95ebf9b0 | 756 | |
0e4a0ae1 TW |
757 | Returns a list of references to all the |
758 | L<Perl::Critic::Violation|Perl::Critic::Violation>s | |
d5835ca8 | 759 | that were found in this Document but were suppressed. |
937b8de0 | 760 | |
d533eee5 | 761 | |
1b936936 ES |
762 | =item C<< is_program() >> |
763 | ||
764 | Returns whether this document is considered to be a program. | |
d533eee5 | 765 | |
d533eee5 ES |
766 | |
767 | =item C<< is_module() >> | |
768 | ||
1b936936 | 769 | Returns whether this document is considered to be a Perl module. |
d533eee5 | 770 | |
5bf96118 CD |
771 | =back |
772 | ||
773 | =head1 AUTHOR | |
774 | ||
2f4b6b33 | 775 | Chris Dolan <cdolan@cpan.org> |
5bf96118 CD |
776 | |
777 | =head1 COPYRIGHT | |
778 | ||
072692c8 | 779 | Copyright (c) 2006-2010 Chris Dolan. |
5bf96118 CD |
780 | |
781 | This program is free software; you can redistribute it and/or modify | |
782 | it under the same terms as Perl itself. The full text of this license | |
783 | can be found in the LICENSE file included with this module. | |
784 | ||
785 | =cut | |
737d3b65 | 786 | |
d5835ca8 | 787 | ############################################################################## |
737d3b65 CD |
788 | # Local Variables: |
789 | # mode: cperl | |
790 | # cperl-indent-level: 4 | |
791 | # fill-column: 78 | |
792 | # indent-tabs-mode: nil | |
793 | # c-indentation-style: bsd | |
794 | # End: | |
96fed375 | 795 | # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : |