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