Login
A little more tweaking. Should probably write some unit tests here.
[gknop/Perl-Critic.git] / lib / Perl / Critic / Document.pm
CommitLineData
6036a254 1##############################################################################
a73f4a71
JRT
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6036a254 6##############################################################################
5bf96118
CD
7
8package Perl::Critic::Document;
9
df6dee2b 10use 5.006001;
5bf96118 11use strict;
58a9e587 12use warnings;
267b39b4
ES
13
14use List::Util qw< max >;
2d2fd196
JRT
15use List::MoreUtils qw< none >;
16
5bf96118 17use PPI::Document;
267b39b4
ES
18use Scalar::Util qw< weaken >;
19use version;
5bf96118 20
6036a254 21#-----------------------------------------------------------------------------
58a9e587 22
173667ce 23our $VERSION = '1.093_01';
5bf96118 24
6036a254 25#-----------------------------------------------------------------------------
5bf96118
CD
26
27our $AUTOLOAD;
937b8de0 28sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking)
6e7d6c9f
CD
29 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
30 return if $function_name eq 'DESTROY';
31 my $self = shift;
32 return $self->{_doc}->$function_name(@_);
5bf96118
CD
33}
34
6036a254 35#-----------------------------------------------------------------------------
5bf96118 36
58a9e587
JRT
37sub new {
38 my ($class, $doc) = @_;
937b8de0 39 my $self = bless {}, $class;
2d2fd196
JRT
40 $self->{_supressed_violations} = {};
41 $self->{_disabled_regions} = {};
937b8de0 42 $self->{_doc} = $doc;
2d2fd196 43 $self->_unfix_shebang();
937b8de0 44 return $self;
5bf96118
CD
45}
46
6036a254 47#-----------------------------------------------------------------------------
58a9e587 48
2b6293b2
CD
49sub ppi_document {
50 my ($self) = @_;
51 return $self->{_doc};
52}
53
54#-----------------------------------------------------------------------------
55
47e1ff34 56sub isa {
6e7d6c9f
CD
57 my ($self, @args) = @_;
58 return $self->SUPER::isa(@args)
59 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
47e1ff34
CD
60}
61
6036a254 62#-----------------------------------------------------------------------------
47e1ff34 63
5bf96118 64sub find {
6e7d6c9f 65 my ($self, $wanted, @more_args) = @_;
5bf96118 66
58a9e587
JRT
67 # This method can only find elements by their class names. For
68 # other types of searches, delegate to the PPI::Document
5bf96118 69 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 70 return $self->{_doc}->find($wanted, @more_args);
5bf96118 71 }
58a9e587
JRT
72
73 # Build the class cache if it doesn't exist. This happens at most
74 # once per Perl::Critic::Document instance. %elements of will be
75 # populated as a side-effect of calling the $finder_sub coderef
76 # that is produced by the caching_finder() closure.
5bf96118 77 if ( !$self->{_elements_of} ) {
389109ec 78
58a9e587 79 my %cache = ( 'PPI::Document' => [ $self ] );
389109ec
JRT
80
81 # The cache refers to $self, and $self refers to the cache. This
82 # creates a circular reference that leaks memory (i.e. $self is not
83 # destroyed until execution is complete). By weakening the reference,
84 # we allow perl to collect the garbage properly.
85 weaken( $cache{'PPI::Document'}->[0] );
86
58a9e587
JRT
87 my $finder_coderef = _caching_finder( \%cache );
88 $self->{_doc}->find( $finder_coderef );
89 $self->{_elements_of} = \%cache;
90 }
91
92 # find() must return false-but-defined on fail
93 return $self->{_elements_of}->{$wanted} || q{};
94}
95
6036a254 96#-----------------------------------------------------------------------------
58a9e587 97
fb21e21e 98sub find_first {
6e7d6c9f 99 my ($self, $wanted, @more_args) = @_;
fb21e21e
CD
100
101 # This method can only find elements by their class names. For
102 # other types of searches, delegate to the PPI::Document
103 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 104 return $self->{_doc}->find_first($wanted, @more_args);
fb21e21e
CD
105 }
106
107 my $result = $self->find($wanted);
108 return $result ? $result->[0] : $result;
109}
110
6036a254 111#-----------------------------------------------------------------------------
fb21e21e 112
f5eeac3b 113sub find_any {
6e7d6c9f 114 my ($self, $wanted, @more_args) = @_;
f5eeac3b
CD
115
116 # This method can only find elements by their class names. For
117 # other types of searches, delegate to the PPI::Document
118 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 119 return $self->{_doc}->find_any($wanted, @more_args);
f5eeac3b
CD
120 }
121
122 my $result = $self->find($wanted);
123 return $result ? 1 : $result;
124}
125
6036a254 126#-----------------------------------------------------------------------------
f5eeac3b 127
60108aef
CD
128sub filename {
129 my ($self) = @_;
130 return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
131}
132
6036a254 133#-----------------------------------------------------------------------------
60108aef 134
267b39b4
ES
135sub highest_explicit_perl_version {
136 my ($self) = @_;
137
138 my $highest_explicit_perl_version =
139 $self->{_highest_explicit_perl_version};
140
141 if ( not exists $self->{_highest_explicit_perl_version} ) {
142 my $includes = $self->find( \&_is_a_version_statement );
143
144 if ($includes) {
1ebef5a9
ES
145 # Note: this will complain about underscores, e.g. "use
146 # 5.008_000". However, nothing important should be depending upon
147 # alpha perl versions and marking non-alpha versions as alpha is
148 # bad in and of itself. Note that this contradicts an example in
149 # perlfunc about "use".
267b39b4
ES
150 $highest_explicit_perl_version =
151 max map { version->new( $_->version() ) } @{$includes};
152 }
153 else {
154 $highest_explicit_perl_version = undef;
155 }
156
157 $self->{_highest_explicit_perl_version} =
158 $highest_explicit_perl_version;
159 }
160
161 return $highest_explicit_perl_version if $highest_explicit_perl_version;
162 return;
163}
164
937b8de0
JRT
165#-----------------------------------------------------------------------------
166
2d2fd196 167sub mark_disabled_regions {
937b8de0 168 my ($self, @site_policies) = @_;
937b8de0 169
2d2fd196
JRT
170 my $nodes_ref = $self->find('PPI::Token::Comment') || return;
171 $self->_disable_shebang_region($nodes_ref, \@site_policies);
172 $self->_disable_other_regions($nodes_ref, \@site_policies);
937b8de0
JRT
173 return $self;
174}
175
176#-----------------------------------------------------------------------------
177
2d2fd196 178sub line_is_disabled {
937b8de0 179 my ($self, $line, $policy_name) = @_;
2d2fd196
JRT
180
181 # HACK: This Policy is special. If it is active, it cannot be
182 # disabled by a "## no critic" marker. Rather than create a general
183 # hook in Policy.pm for enabling this behavior, we chose to hack
184 # it here, since this isn't the kind of thing that most policies
185 # should be doning.
2f4b6b33
JRT
186
187 return 0 if $policy_name eq
2d2fd196
JRT
188 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic';
189
e2fc36b3 190 for my $region ( $self->_disabled_regions($policy_name) ) {
2d2fd196
JRT
191 return 1 if $line >= $region->[0] and $line <= $region->[-1];
192 }
193
937b8de0
JRT
194 return 0;
195}
196
197#-----------------------------------------------------------------------------
198
2d2fd196
JRT
199sub mark_supressed_violation {
200 my ($self, $line, $policy_name) = @_;
201 $self->{_supressed_violations}{$policy_name}{$line} = 1;
202 return $self;
203}
4880392e 204
2d2fd196 205#-----------------------------------------------------------------------------
4880392e 206
2d2fd196
JRT
207sub useless_no_critic_warnings {
208 my ($self) = @_;
4880392e 209
95ebf9b0
JRT
210 my @warnings = ();
211 my $file = $self->filename() || 'UNKNOWN';
4880392e 212
2d2fd196
JRT
213 my %disabled_regions = %{ $self->{_disabled_regions} };
214 for my $policy (keys %disabled_regions) {
4880392e 215
2d2fd196
JRT
216 my @regions = @{ $disabled_regions{$policy} };
217
218 for my $region (@regions) {
219 if (none {$self->_violation_was_supressed($_, $policy)} @{$region} ) {
220 my $start = $region->[0];
e2fc36b3
JRT
221 my $which_policy = $policy eq 'ALL' ? 'all Policies' : $policy;
222 push @warnings, qq{Useless disabling of $which_policy in "$file" at line $start.};
95ebf9b0
JRT
223 }
224 }
225 }
95ebf9b0
JRT
226 return @warnings;
227}
228
229#-----------------------------------------------------------------------------
230
267b39b4
ES
231sub _is_a_version_statement {
232 my (undef, $element) = @_;
233
234 return 0 if not $element->isa('PPI::Statement::Include');
235 return 1 if $element->version();
236 return 0;
237}
238
239#-----------------------------------------------------------------------------
240
58a9e587
JRT
241sub _caching_finder {
242
243 my $cache_ref = shift; # These vars will persist for the life
244 my %isa_cache = (); # of the code ref that this sub returns
245
246
247 # Gather up all the PPI elements and sort by @ISA. Note: if any
248 # instances used multiple inheritance, this implementation would
249 # lead to multiple copies of $element in the $elements_of lists.
250 # However, PPI::* doesn't do multiple inheritance, so we are safe
251
252 return sub {
6e7d6c9f 253 my (undef, $element) = @_;
58a9e587
JRT
254 my $classes = $isa_cache{ref $element};
255 if ( !$classes ) {
256 $classes = [ ref $element ];
257 # Use a C-style loop because we append to the classes array inside
258 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
259 no strict 'refs'; ## no critic(ProhibitNoStrict)
260 push @{$classes}, @{"$classes->[$i]::ISA"};
261 $cache_ref->{$classes->[$i]} ||= [];
5bf96118 262 }
58a9e587
JRT
263 $isa_cache{$classes->[0]} = $classes;
264 }
5bf96118 265
58a9e587
JRT
266 for my $class ( @{$classes} ) {
267 push @{$cache_ref->{$class}}, $element;
268 }
5bf96118 269
58a9e587
JRT
270 return 0; # 0 tells find() to keep traversing, but not to store this $element
271 };
5bf96118
CD
272}
273
6036a254 274#-----------------------------------------------------------------------------
58a9e587 275
e2fc36b3
JRT
276sub _disabled_regions {
277 my ($self, $policy_name) = @_;
278 my @disabled_regions = ();
279
280 # Get policy-specific reigions
281 if ( my $region = $self->{_disabled_regions}->{$policy_name} ) {
282 push @disabled_regions, @{$region};
283 }
284
285 # Get regions for all policies
286 if ( my $region = $self->{_disabled_regions}->{ALL} ) {
287 push @disabled_regions, @{$region};
288 }
289
290 return @disabled_regions;
291}
292
293#-----------------------------------------------------------------------------
294
2d2fd196
JRT
295sub _violation_was_supressed {
296 my ($self, $line, $policy) = @_;
297 return 1 if $self->{_supressed_violations}->{$policy}->{$line};
298 return 0;
299}
300
301#-----------------------------------------------------------------------------
937b8de0 302
2d2fd196
JRT
303sub _mark_disabled_region {
304 my ($self, $starting_line, $ending_line, @disabled_policies) = @_;
305 return if not @disabled_policies;
937b8de0 306
2d2fd196
JRT
307 for my $policy (@disabled_policies) {
308 my $region = [$starting_line .. $ending_line];
309 $self->{_disabled_regions}->{$policy} ||= [];
310 push @{ $self->{_disabled_regions}->{$policy} }, $region;
311 }
937b8de0 312
2d2fd196 313 return $self;
937b8de0
JRT
314}
315
316#-----------------------------------------------------------------------------
317
2d2fd196
JRT
318sub _disable_shebang_region {
319 my ($self, $nodes_ref, $site_policies) = @_;
937b8de0 320
2d2fd196 321 my $first_comment = $nodes_ref->[0] || return;
937b8de0
JRT
322 my $shebang_no_critic = qr{\A [#]! .*? [#][#] \s* no \s+ critic}xms;
323
324 # Special case for the very beginning of the file: allow "##no critic" after the shebang
2d2fd196
JRT
325 my $loc = $first_comment->location();
326 if (1 == $loc->[0] && 1 == $loc->[1] && $first_comment =~ $shebang_no_critic) {
327 my @disabled_policies = _parse_nocritic_import($first_comment, $site_policies);
328 $self->_mark_disabled_region(1, 1, @disabled_policies);
937b8de0 329 }
2d2fd196
JRT
330
331 return $self;
937b8de0
JRT
332}
333
334#-----------------------------------------------------------------------------
335
2d2fd196
JRT
336sub _disable_other_regions {
337 my ($self, $nodes_ref, $site_policies) = @_;
937b8de0
JRT
338
339 my $no_critic = qr{\A \s* [#][#] \s* no \s+ critic}xms;
340 my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}xms;
341
342 PRAGMA:
343 for my $pragma ( grep { $_ =~ $no_critic } @{$nodes_ref} ) {
344
345 # Parse out the list of Policy names after the
346 # 'no critic' pragma. I'm thinking of this just
347 # like a an C<import> argument for real pragmas.
348 my @no_policies = _parse_nocritic_import($pragma, $site_policies);
349
350 # Grab surrounding nodes to determine the context.
351 # This determines whether the pragma applies to
352 # the current line or the block that follows.
353 my $parent = $pragma->parent();
354 my $grandparent = $parent ? $parent->parent() : undef;
355 my $sib = $pragma->sprevious_sibling();
356
357
358 # Handle single-line usage on simple statements
359 if ( $sib && $sib->location->[0] == $pragma->location->[0] ) {
360 my $line = $pragma->location->[0];
2d2fd196 361 $self->_mark_disabled_region($line, $line, @no_policies);
937b8de0
JRT
362 next PRAGMA;
363 }
364
365
366 # Handle single-line usage on compound statements
367 if ( ref $parent eq 'PPI::Structure::Block' ) {
368 if ( ref $grandparent eq 'PPI::Statement::Compound'
369 || ref $grandparent eq 'PPI::Statement::Sub' ) {
370 if ( $parent->location->[0] == $pragma->location->[0] ) {
371 my $line = $grandparent->location->[0];
2d2fd196 372 $self->_mark_disabled_region($line, $line, @no_policies);
937b8de0
JRT
373 next PRAGMA;
374 }
375 }
376 }
377
378
379 # Handle multi-line usage. This is either a "no critic" ..
380 # "use critic" region or a block where "no critic" persists
381 # until the end of the scope. The start is the always the "no
382 # critic" which we already found. So now we have to search
383 # for the end.
384
385 my $start = $pragma;
386 my $end = $pragma;
387
388 SIB:
389 while ( my $esib = $end->next_sibling() ) {
390 $end = $esib; # keep track of last sibling encountered in this scope
4880392e 391 last SIB if $esib->isa('PPI::Token::Comment') && $esib =~ $use_critic;
937b8de0
JRT
392 }
393
394 # We either found an end or hit the end of the scope.
2d2fd196
JRT
395 my ($starting_line, $ending_line) = ($start->location->[0], $end->location->[0]);
396 $self->_mark_disabled_region($starting_line, $ending_line, @no_policies);
937b8de0
JRT
397 }
398
2d2fd196 399 return $self;
937b8de0
JRT
400}
401
402#-----------------------------------------------------------------------------
403
404sub _parse_nocritic_import {
405
406 my ($pragma, $site_policies) = @_;
407
408 my $module = qr{ [\w:]+ }xms;
409 my $delim = qr{ \s* [,\s] \s* }xms;
410 my $qw = qr{ (?: qw )? }xms;
411 my $qualifier = qr{ $qw [(]? \s* ( $module (?: $delim $module)* ) \s* [)]? }xms;
e2fc36b3 412 my $no_critic = qr{ \#\# \s* no \s+ critic \s* $qualifier }xms;
937b8de0
JRT
413
414 if ( my ($module_list) = $pragma =~ $no_critic ) {
415 my @modules = split $delim, $module_list;
416
417 # Compose the specified modules into a regex alternation. Wrap each
418 # in a no-capturing group to permit "|" in the modules specification
419 # (backward compatibility)
420 my $re = join q{|}, map {"(?:$_)"} @modules;
421 return grep {m/$re/ixms} @{$site_policies};
422 }
423
424 # Default to disabling ALL policies.
425 return qw(ALL);
426}
427
428#-----------------------------------------------------------------------------
429
430sub _unfix_shebang {
431
2d2fd196
JRT
432 my ($self) = @_;
433
937b8de0
JRT
434 # When you install a script using ExtUtils::MakeMaker or Module::Build, it
435 # inserts some magical code into the top of the file (just after the
436 # shebang). This code allows people to call your script using a shell,
437 # like `sh my_script`. Unfortunately, this code causes several Policy
438 # violations, so we just disable it as if a "## no critic" comment had
439 # been attached.
440
2d2fd196 441 my $first_stmnt = $self->schild(0) || return $self;
937b8de0
JRT
442
443 # Different versions of MakeMaker and Build use slightly different shebang
444 # fixing strings. This matches most of the ones I've found in my own Perl
445 # distribution, but it may not be bullet-proof.
446
e2fc36b3 447 my $fixin_rx = qr{^eval 'exec .* \$0 \${1\+"\$@"}'\s*[\r\n]\s*if.+;}ms; ## no critic (ExtendedFormatting)
937b8de0
JRT
448 if ( $first_stmnt =~ $fixin_rx ) {
449 my $line = $first_stmnt->location()->[0];
2d2fd196 450 $self->_mark_disabled_region($line, $line+1, 'ALL');
937b8de0
JRT
451 }
452
453 #No magic shebang was found!
2d2fd196 454 return $self;
937b8de0
JRT
455}
456
457#-----------------------------------------------------------------------------
458
5bf96118 4591;
58a9e587 460
5bf96118
CD
461__END__
462
a73f4a71
JRT
463=pod
464
465=for stopwords pre-caches
466
5bf96118
CD
467=head1 NAME
468
c728943a 469Perl::Critic::Document - Caching wrapper around a PPI::Document.
5bf96118 470
267b39b4 471
5bf96118
CD
472=head1 SYNOPSIS
473
474 use PPI::Document;
475 use Perl::Critic::Document;
476 my $doc = PPI::Document->new('Foo.pm');
477 $doc = Perl::Critic::Document->new($doc);
478 ## Then use the instance just like a PPI::Document
479
267b39b4 480
5bf96118
CD
481=head1 DESCRIPTION
482
483Perl::Critic does a lot of iterations over the PPI document tree via
484the C<PPI::Document::find()> method. To save some time, this class
485pre-caches a lot of the common C<find()> calls in a single traversal.
486Then, on subsequent requests we return the cached data.
487
488This is implemented as a facade, where method calls are handed to the
489stored C<PPI::Document> instance.
490
267b39b4 491
5bf96118
CD
492=head1 CAVEATS
493
494This facade does not implement the overloaded operators from
11f53956
ES
495L<PPI::Document|PPI::Document> (that is, the C<use overload ...>
496work). Therefore, users of this facade must not rely on that syntactic
497sugar. So, for example, instead of C<my $source = "$doc";> you should
498write C<my $source = $doc->content();>
5bf96118
CD
499
500Perhaps there is a CPAN module out there which implements a facade
501better than we do here?
502
267b39b4
ES
503
504=head1 CONSTRUCTOR
505
506=over
507
508=item C<< new($doc) >>
509
510Create a new instance referencing a PPI::Document instance.
511
512
513=back
514
515
5bf96118
CD
516=head1 METHODS
517
518=over
519
267b39b4 520=item C<< new($doc) >>
7076e807
CD
521
522Create a new instance referencing a PPI::Document instance.
523
267b39b4
ES
524
525=item C<< ppi_document() >>
2b6293b2 526
11f53956
ES
527Accessor for the wrapped PPI::Document instance. Note that altering
528this instance in any way can cause unpredictable failures in
529Perl::Critic's subsequent analysis because some caches may fall out of
530date.
2b6293b2 531
5bf96118 532
267b39b4
ES
533=item C<< find($wanted) >>
534
535=item C<< find_first($wanted) >>
fb21e21e 536
267b39b4 537=item C<< find_any($wanted) >>
f5eeac3b 538
fb21e21e 539If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
540Otherwise we forward the call to the corresponding method of the
541C<PPI::Document> instance.
5bf96118 542
267b39b4
ES
543
544=item C<< filename() >>
e7f2d995
CD
545
546Returns the filename for the source code if applicable
547(PPI::Document::File) or C<undef> otherwise (PPI::Document).
548
267b39b4
ES
549
550=item C<< isa( $classname ) >>
242f7b08 551
11f53956
ES
552To be compatible with other modules that expect to get a
553PPI::Document, the Perl::Critic::Document class masquerades as the
554PPI::Document class.
242f7b08 555
267b39b4
ES
556
557=item C<< highest_explicit_perl_version() >>
558
11f53956
ES
559Returns a L<version|version> object for the highest Perl version
560requirement declared in the document via a C<use> or C<require>
561statement. Returns nothing if there is no version statement.
267b39b4
ES
562
563
2d2fd196 564=item C<< mark_disabled_regions( @policy_names ) >>
937b8de0
JRT
565
566Scans the document for C<"## no critic"> pseudo-pragmas and builds
567an internal table of which of the listed C<@policy_names> have
2d2fd196
JRT
568been disabled at each line. Unless you want to ignore the
569C<"## no critic"> markers, you should call this method before
570critiquing the document. Returns C<$self>.
937b8de0
JRT
571
572
2d2fd196 573=item C<< line_is_disabled($line, $policy_name) >>
937b8de0
JRT
574
575Returns true if the given C<$policy_name> has been disabled for
576at C<$line> in this document. Otherwise, returns false.
577
2d2fd196
JRT
578
579=item C<< mark_supressed_violation($line, $policy_name) >>
580
581Indicates to this Document that a violation of policy C<$policy_name>
582was found at line c<$line>, but was not reported because it
583fell on a line that had been disabled by a C<"## no critic"> marker.
584This is how the Document figures out if there are any useless
585C<"## no critic"> markers in the file. Returns C<$self>.
586
587
95ebf9b0
JRT
588=item C<< useless_no_critic_warnings(@violations) >>
589
590Given a list of violation objects that are assumed to have been found
591in this Document, returns a warning message for each line where a
592policy was disabled using a C<"##no critic"> pseudo-pragma, but
593no violation was actually found on that line. If multiple policies
594are disabled on a given line, then you'll get a warning message
595for each policy.
596
937b8de0 597
5bf96118
CD
598=back
599
267b39b4 600
5bf96118
CD
601=head1 AUTHOR
602
2f4b6b33 603Chris Dolan <cdolan@cpan.org>
5bf96118 604
267b39b4 605
5bf96118
CD
606=head1 COPYRIGHT
607
20dfddeb 608Copyright (c) 2006-2008 Chris Dolan. All rights reserved.
5bf96118
CD
609
610This program is free software; you can redistribute it and/or modify
611it under the same terms as Perl itself. The full text of this license
612can be found in the LICENSE file included with this module.
613
614=cut
737d3b65
CD
615
616# Local Variables:
617# mode: cperl
618# cperl-indent-level: 4
619# fill-column: 78
620# indent-tabs-mode: nil
621# c-indentation-style: bsd
622# End:
96fed375 623# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :