Login
Apply unmodified patch to P::C::Document for dealing with requiring of
[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 13
d5835ca8 14use Carp qw< confess >;
2d2fd196 15
5bf96118 16use PPI::Document;
d5835ca8
JRT
17use PPI::Document::File;
18
df9f8d80 19use List::Util;
d5835ca8 20use Scalar::Util qw< blessed weaken >;
267b39b4 21use version;
5bf96118 22
d5835ca8
JRT
23use Perl::Critic::Annotation;
24use Perl::Critic::Exception::Parse qw{ throw_parse };
25
6036a254 26#-----------------------------------------------------------------------------
58a9e587 27
5b6b8968 28our $VERSION = '1.094001';
5bf96118 29
6036a254 30#-----------------------------------------------------------------------------
5bf96118
CD
31
32our $AUTOLOAD;
937b8de0 33sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking)
6e7d6c9f
CD
34 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
35 return if $function_name eq 'DESTROY';
36 my $self = shift;
37 return $self->{_doc}->$function_name(@_);
5bf96118
CD
38}
39
6036a254 40#-----------------------------------------------------------------------------
5bf96118 41
58a9e587 42sub new {
d5835ca8 43 my ($class, @args) = @_;
937b8de0 44 my $self = bless {}, $class;
d5835ca8
JRT
45 return $self->_init(@args);
46}
47
48#-----------------------------------------------------------------------------
49
50sub _init {
51
52 my ($self, $source_code) = @_;
53
54 # $source_code can be a file name, or a reference to a
55 # PPI::Document, or a reference to a scalar containing source
56 # code. In the last case, PPI handles the translation for us.
57
58 my $doc = _is_ppi_doc( $source_code ) ? $source_code
59 : ref $source_code ? PPI::Document->new($source_code)
60 : PPI::Document::File->new($source_code);
61
62 # Bail on error
63 if ( not defined $doc ) {
64 my $errstr = PPI::Document::errstr();
65 my $file = ref $source_code ? undef : $source_code;
66 throw_parse
67 message => qq<Can't parse code: $errstr>,
68 file_name => $file;
69 }
70
937b8de0 71 $self->{_doc} = $doc;
d5835ca8
JRT
72 $self->{_annotations} = [];
73 $self->{_suppressed_violations} = [];
74 $self->{_disabled_line_map} = {};
75 $self->index_locations();
76 $self->_disable_shebang_fix();
77
937b8de0 78 return $self;
5bf96118
CD
79}
80
6036a254 81#-----------------------------------------------------------------------------
58a9e587 82
d5835ca8
JRT
83sub _is_ppi_doc {
84 my ($ref) = @_;
85 return blessed($ref) && $ref->isa('PPI::Document');
86}
87
88#-----------------------------------------------------------------------------
89
2b6293b2
CD
90sub ppi_document {
91 my ($self) = @_;
92 return $self->{_doc};
93}
94
95#-----------------------------------------------------------------------------
96
47e1ff34 97sub isa {
6e7d6c9f
CD
98 my ($self, @args) = @_;
99 return $self->SUPER::isa(@args)
100 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
47e1ff34
CD
101}
102
6036a254 103#-----------------------------------------------------------------------------
47e1ff34 104
5bf96118 105sub find {
6e7d6c9f 106 my ($self, $wanted, @more_args) = @_;
5bf96118 107
58a9e587
JRT
108 # This method can only find elements by their class names. For
109 # other types of searches, delegate to the PPI::Document
5bf96118 110 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 111 return $self->{_doc}->find($wanted, @more_args);
5bf96118 112 }
58a9e587
JRT
113
114 # Build the class cache if it doesn't exist. This happens at most
115 # once per Perl::Critic::Document instance. %elements of will be
116 # populated as a side-effect of calling the $finder_sub coderef
117 # that is produced by the caching_finder() closure.
5bf96118 118 if ( !$self->{_elements_of} ) {
389109ec 119
58a9e587 120 my %cache = ( 'PPI::Document' => [ $self ] );
389109ec
JRT
121
122 # The cache refers to $self, and $self refers to the cache. This
123 # creates a circular reference that leaks memory (i.e. $self is not
124 # destroyed until execution is complete). By weakening the reference,
125 # we allow perl to collect the garbage properly.
126 weaken( $cache{'PPI::Document'}->[0] );
127
58a9e587
JRT
128 my $finder_coderef = _caching_finder( \%cache );
129 $self->{_doc}->find( $finder_coderef );
130 $self->{_elements_of} = \%cache;
131 }
132
133 # find() must return false-but-defined on fail
134 return $self->{_elements_of}->{$wanted} || q{};
135}
136
6036a254 137#-----------------------------------------------------------------------------
58a9e587 138
fb21e21e 139sub find_first {
6e7d6c9f 140 my ($self, $wanted, @more_args) = @_;
fb21e21e
CD
141
142 # This method can only find elements by their class names. For
143 # other types of searches, delegate to the PPI::Document
144 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 145 return $self->{_doc}->find_first($wanted, @more_args);
fb21e21e
CD
146 }
147
148 my $result = $self->find($wanted);
149 return $result ? $result->[0] : $result;
150}
151
6036a254 152#-----------------------------------------------------------------------------
fb21e21e 153
f5eeac3b 154sub find_any {
6e7d6c9f 155 my ($self, $wanted, @more_args) = @_;
f5eeac3b
CD
156
157 # This method can only find elements by their class names. For
158 # other types of searches, delegate to the PPI::Document
159 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 160 return $self->{_doc}->find_any($wanted, @more_args);
f5eeac3b
CD
161 }
162
163 my $result = $self->find($wanted);
164 return $result ? 1 : $result;
165}
166
6036a254 167#-----------------------------------------------------------------------------
f5eeac3b 168
60108aef
CD
169sub filename {
170 my ($self) = @_;
c73ba7f3
JRT
171 my $doc = $self->{_doc};
172 return $doc->can('filename') ? $doc->filename() : undef;
60108aef
CD
173}
174
6036a254 175#-----------------------------------------------------------------------------
60108aef 176
267b39b4
ES
177sub highest_explicit_perl_version {
178 my ($self) = @_;
179
180 my $highest_explicit_perl_version =
181 $self->{_highest_explicit_perl_version};
182
183 if ( not exists $self->{_highest_explicit_perl_version} ) {
184 my $includes = $self->find( \&_is_a_version_statement );
185
186 if ($includes) {
df9f8d80
ES
187 # Note: this doesn't use List::Util::max because that func doesn't
188 # use the overloaded ">=" etc of a version object. The reduce()
189 # style lets version.pm take care of all comparing.
190 #
191 # For reference, max() ends up looking at the string converted to
192 # an NV, or something like that. An underscore like "5.005_04"
193 # provokes a warning and is chopped off at "5.005" thus losing the
194 # minor part from the comparison.
195 #
196 # An underscore "5.005_04" is supposed to mean an alpha release
197 # and probably shouldn't be used in a perl version. But it's
198 # shown in perlfunc under "use" (as a number separator), and
199 # appears in several modules supplied with perl 5.10.0 (like
200 # version.pm itself!). At any rate if version.pm can understand
201 # it then that's enough for here.
202 #
267b39b4 203 $highest_explicit_perl_version =
df9f8d80
ES
204 List::Util::reduce { $a >= $b ? $a : $b }
205 map { version->new( $_->version() ) } @{$includes};
267b39b4
ES
206 }
207 else {
208 $highest_explicit_perl_version = undef;
209 }
210
211 $self->{_highest_explicit_perl_version} =
212 $highest_explicit_perl_version;
213 }
214
215 return $highest_explicit_perl_version if $highest_explicit_perl_version;
216 return;
217}
218
937b8de0
JRT
219#-----------------------------------------------------------------------------
220
d5835ca8
JRT
221sub process_annotations {
222 my ($self) = @_;
937b8de0 223
d5835ca8
JRT
224 my @annotations = Perl::Critic::Annotation->create_annotations($self);
225 $self->add_annotation(@annotations);
937b8de0
JRT
226 return $self;
227}
228
229#-----------------------------------------------------------------------------
230
d5835ca8
JRT
231sub line_is_disabled_for_policy {
232 my ($self, $line, $policy) = @_;
233 my $policy_name = ref $policy || $policy;
2d2fd196
JRT
234
235 # HACK: This Policy is special. If it is active, it cannot be
d1237298 236 # disabled by a "## no critic" annotation. Rather than create a general
2d2fd196 237 # hook in Policy.pm for enabling this behavior, we chose to hack
d5835ca8 238 # it here, since this isn't the kind of thing that most policies do
2f4b6b33
JRT
239
240 return 0 if $policy_name eq
2d2fd196
JRT
241 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic';
242
d5835ca8
JRT
243 return 1 if $self->{_disabled_line_map}->{$line}->{$policy_name};
244 return 1 if $self->{_disabled_line_map}->{$line}->{ALL};
937b8de0
JRT
245 return 0;
246}
247
248#-----------------------------------------------------------------------------
249
d5835ca8
JRT
250sub add_annotation {
251 my ($self, @annotations) = @_;
252
253 # Add annotation to our private map for quick lookup
254 for my $annotation (@annotations) {
255
256 my ($start, $end) = $annotation->effective_range();
257 my @affected_policies = $annotation->disables_all_policies ?
258 qw(ALL) : $annotation->disabled_policies();
259
260 # TODO: Find clever way to do this with hash slices
261 for my $line ($start .. $end) {
262 for my $policy (@affected_policies) {
263 $self->{_disabled_line_map}->{$line}->{$policy} = 1;
264 }
265 }
266 }
267
268 push @{ $self->{_annotations} }, @annotations;
2d2fd196
JRT
269 return $self;
270}
4880392e 271
2d2fd196 272#-----------------------------------------------------------------------------
4880392e 273
d5835ca8 274sub annotations {
2d2fd196 275 my ($self) = @_;
d5835ca8
JRT
276 return @{ $self->{_annotations} };
277}
4880392e 278
d5835ca8 279#-----------------------------------------------------------------------------
4880392e 280
d5835ca8
JRT
281sub add_suppressed_violation {
282 my ($self, $violation) = @_;
283 push @{$self->{_suppressed_violations}}, $violation;
284 return $self;
285}
4880392e 286
d5835ca8 287#-----------------------------------------------------------------------------
2d2fd196 288
d5835ca8
JRT
289sub suppressed_violations {
290 my ($self) = @_;
291 return @{ $self->{_suppressed_violations} };
95ebf9b0
JRT
292}
293
294#-----------------------------------------------------------------------------
d5835ca8 295# PRIVATE functions & methods
95ebf9b0 296
267b39b4
ES
297sub _is_a_version_statement {
298 my (undef, $element) = @_;
299
300 return 0 if not $element->isa('PPI::Statement::Include');
301 return 1 if $element->version();
302 return 0;
303}
304
305#-----------------------------------------------------------------------------
306
58a9e587
JRT
307sub _caching_finder {
308
309 my $cache_ref = shift; # These vars will persist for the life
310 my %isa_cache = (); # of the code ref that this sub returns
311
312
313 # Gather up all the PPI elements and sort by @ISA. Note: if any
314 # instances used multiple inheritance, this implementation would
315 # lead to multiple copies of $element in the $elements_of lists.
316 # However, PPI::* doesn't do multiple inheritance, so we are safe
317
318 return sub {
6e7d6c9f 319 my (undef, $element) = @_;
58a9e587
JRT
320 my $classes = $isa_cache{ref $element};
321 if ( !$classes ) {
322 $classes = [ ref $element ];
323 # Use a C-style loop because we append to the classes array inside
324 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
325 no strict 'refs'; ## no critic(ProhibitNoStrict)
326 push @{$classes}, @{"$classes->[$i]::ISA"};
327 $cache_ref->{$classes->[$i]} ||= [];
5bf96118 328 }
58a9e587
JRT
329 $isa_cache{$classes->[0]} = $classes;
330 }
5bf96118 331
58a9e587
JRT
332 for my $class ( @{$classes} ) {
333 push @{$cache_ref->{$class}}, $element;
334 }
5bf96118 335
58a9e587
JRT
336 return 0; # 0 tells find() to keep traversing, but not to store this $element
337 };
5bf96118
CD
338}
339
6036a254 340#-----------------------------------------------------------------------------
58a9e587 341
d5835ca8 342sub _disable_shebang_fix {
2d2fd196
JRT
343 my ($self) = @_;
344
937b8de0
JRT
345 # When you install a script using ExtUtils::MakeMaker or Module::Build, it
346 # inserts some magical code into the top of the file (just after the
347 # shebang). This code allows people to call your script using a shell,
348 # like `sh my_script`. Unfortunately, this code causes several Policy
d1237298 349 # violations, so we disable them as if they had "## no critic" annotations.
937b8de0 350
d5835ca8 351 my $first_stmnt = $self->schild(0) || return;
937b8de0
JRT
352
353 # Different versions of MakeMaker and Build use slightly different shebang
354 # fixing strings. This matches most of the ones I've found in my own Perl
355 # distribution, but it may not be bullet-proof.
356
66d796fa 357 my $fixin_rx = qr<^eval 'exec .* \$0 \${1\+"\$@"}'\s*[\r\n]\s*if.+;>ms; ## no critic (ExtendedFormatting)
937b8de0 358 if ( $first_stmnt =~ $fixin_rx ) {
d5835ca8
JRT
359 my $line = $first_stmnt->location->[0];
360 $self->{_disabled_line_map}->{$line}->{ALL} = 1;
361 $self->{_disabled_line_map}->{$line + 1}->{ALL} = 1;
937b8de0
JRT
362 }
363
2d2fd196 364 return $self;
937b8de0
JRT
365}
366
367#-----------------------------------------------------------------------------
368
5bf96118 3691;
58a9e587 370
5bf96118
CD
371__END__
372
a73f4a71
JRT
373=pod
374
375=for stopwords pre-caches
376
5bf96118
CD
377=head1 NAME
378
c728943a 379Perl::Critic::Document - Caching wrapper around a PPI::Document.
5bf96118 380
267b39b4 381
5bf96118
CD
382=head1 SYNOPSIS
383
384 use PPI::Document;
385 use Perl::Critic::Document;
386 my $doc = PPI::Document->new('Foo.pm');
387 $doc = Perl::Critic::Document->new($doc);
388 ## Then use the instance just like a PPI::Document
389
267b39b4 390
5bf96118
CD
391=head1 DESCRIPTION
392
393Perl::Critic does a lot of iterations over the PPI document tree via
394the C<PPI::Document::find()> method. To save some time, this class
395pre-caches a lot of the common C<find()> calls in a single traversal.
396Then, on subsequent requests we return the cached data.
397
398This is implemented as a facade, where method calls are handed to the
399stored C<PPI::Document> instance.
400
267b39b4 401
5bf96118
CD
402=head1 CAVEATS
403
404This facade does not implement the overloaded operators from
11f53956
ES
405L<PPI::Document|PPI::Document> (that is, the C<use overload ...>
406work). Therefore, users of this facade must not rely on that syntactic
407sugar. So, for example, instead of C<my $source = "$doc";> you should
408write C<my $source = $doc->content();>
5bf96118
CD
409
410Perhaps there is a CPAN module out there which implements a facade
411better than we do here?
412
267b39b4
ES
413
414=head1 CONSTRUCTOR
415
416=over
417
d5835ca8 418=item C<< new($source_code) >>
267b39b4 419
d5835ca8
JRT
420Create a new instance referencing a PPI::Document instance. The
421C<$source_code> can be the name of a file, a reference to a scalar
fcb2381b 422containing actual source code, or a L<PPI::Document> or
d5835ca8 423L<PPI::Document::File>.
267b39b4
ES
424
425=back
426
5bf96118
CD
427=head1 METHODS
428
429=over
430
267b39b4 431=item C<< ppi_document() >>
2b6293b2 432
11f53956
ES
433Accessor for the wrapped PPI::Document instance. Note that altering
434this instance in any way can cause unpredictable failures in
435Perl::Critic's subsequent analysis because some caches may fall out of
436date.
2b6293b2 437
5bf96118 438
267b39b4
ES
439=item C<< find($wanted) >>
440
441=item C<< find_first($wanted) >>
fb21e21e 442
267b39b4 443=item C<< find_any($wanted) >>
f5eeac3b 444
fb21e21e 445If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
446Otherwise we forward the call to the corresponding method of the
447C<PPI::Document> instance.
5bf96118 448
267b39b4
ES
449
450=item C<< filename() >>
e7f2d995
CD
451
452Returns the filename for the source code if applicable
453(PPI::Document::File) or C<undef> otherwise (PPI::Document).
454
267b39b4
ES
455
456=item C<< isa( $classname ) >>
242f7b08 457
11f53956
ES
458To be compatible with other modules that expect to get a
459PPI::Document, the Perl::Critic::Document class masquerades as the
460PPI::Document class.
242f7b08 461
267b39b4
ES
462
463=item C<< highest_explicit_perl_version() >>
464
11f53956
ES
465Returns a L<version|version> object for the highest Perl version
466requirement declared in the document via a C<use> or C<require>
467statement. Returns nothing if there is no version statement.
267b39b4 468
d5835ca8 469=item C<< process_annotations() >>
267b39b4 470
d5835ca8
JRT
471Causes this Document to scan itself and mark which lines &
472policies are disabled by the C<"## no critic"> annotations.
937b8de0 473
d5835ca8 474=item C<< line_is_disabled_for_policy($line, $policy_object) >>
937b8de0 475
fcb2381b 476Returns true if the given C<$policy_object> or C<$policy_name> has
d5835ca8 477been disabled for at C<$line> in this Document. Otherwise, returns false.
937b8de0 478
d5835ca8 479=item C<< add_annotation( $annotation ) >>
937b8de0 480
d5835ca8 481Adds an C<$annotation> object to this Document.
2d2fd196 482
d5835ca8 483=item C<< annotations() >>
2d2fd196 484
d5835ca8
JRT
485Returns a list containing all the L<Perl::Critic::Annotation> that
486were found in this Document.
2d2fd196 487
d5835ca8 488=item C<< add_suppressed_violation($violation) >>
2d2fd196 489
fcb2381b 490Informs this Document that a C<$violation> was found but not reported
d5835ca8
JRT
491because it fell on a line that had been suppressed by a C<"## no critic">
492annotation. Returns C<$self>.
95ebf9b0 493
d5835ca8 494=item C<< suppressed_violations() >>
95ebf9b0 495
d5835ca8
JRT
496Returns a list of references to all the L<Perl::Critic::Violation>s
497that were found in this Document but were suppressed.
937b8de0 498
5bf96118
CD
499=back
500
501=head1 AUTHOR
502
2f4b6b33 503Chris Dolan <cdolan@cpan.org>
5bf96118
CD
504
505=head1 COPYRIGHT
506
7537474e 507Copyright (c) 2006-2009 Chris Dolan. All rights reserved.
5bf96118
CD
508
509This program is free software; you can redistribute it and/or modify
510it under the same terms as Perl itself. The full text of this license
511can be found in the LICENSE file included with this module.
512
513=cut
737d3b65 514
d5835ca8 515##############################################################################
737d3b65
CD
516# Local Variables:
517# mode: cperl
518# cperl-indent-level: 4
519# fill-column: 78
520# indent-tabs-mode: nil
521# c-indentation-style: bsd
522# End:
96fed375 523# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :