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