Login
Add the xt directory to no_index in Build.PL.
[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
be4331b3 21our $VERSION = '1.090';
5bf96118 22
6036a254 23#-----------------------------------------------------------------------------
5bf96118
CD
24
25our $AUTOLOAD;
6e7d6c9f
CD
26sub AUTOLOAD { ## no critic(ProhibitAutoloading,ArgUnpacking)
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) = @_;
5bf96118
CD
37 return bless { _doc => $doc }, $class;
38}
39
6036a254 40#-----------------------------------------------------------------------------
58a9e587 41
2b6293b2
CD
42sub ppi_document {
43 my ($self) = @_;
44 return $self->{_doc};
45}
46
47#-----------------------------------------------------------------------------
48
47e1ff34 49sub isa {
6e7d6c9f
CD
50 my ($self, @args) = @_;
51 return $self->SUPER::isa(@args)
52 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
47e1ff34
CD
53}
54
6036a254 55#-----------------------------------------------------------------------------
47e1ff34 56
5bf96118 57sub find {
6e7d6c9f 58 my ($self, $wanted, @more_args) = @_;
5bf96118 59
58a9e587
JRT
60 # This method can only find elements by their class names. For
61 # other types of searches, delegate to the PPI::Document
5bf96118 62 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 63 return $self->{_doc}->find($wanted, @more_args);
5bf96118 64 }
58a9e587
JRT
65
66 # Build the class cache if it doesn't exist. This happens at most
67 # once per Perl::Critic::Document instance. %elements of will be
68 # populated as a side-effect of calling the $finder_sub coderef
69 # that is produced by the caching_finder() closure.
5bf96118 70 if ( !$self->{_elements_of} ) {
389109ec 71
58a9e587 72 my %cache = ( 'PPI::Document' => [ $self ] );
389109ec
JRT
73
74 # The cache refers to $self, and $self refers to the cache. This
75 # creates a circular reference that leaks memory (i.e. $self is not
76 # destroyed until execution is complete). By weakening the reference,
77 # we allow perl to collect the garbage properly.
78 weaken( $cache{'PPI::Document'}->[0] );
79
58a9e587
JRT
80 my $finder_coderef = _caching_finder( \%cache );
81 $self->{_doc}->find( $finder_coderef );
82 $self->{_elements_of} = \%cache;
83 }
84
85 # find() must return false-but-defined on fail
86 return $self->{_elements_of}->{$wanted} || q{};
87}
88
6036a254 89#-----------------------------------------------------------------------------
58a9e587 90
fb21e21e 91sub find_first {
6e7d6c9f 92 my ($self, $wanted, @more_args) = @_;
fb21e21e
CD
93
94 # This method can only find elements by their class names. For
95 # other types of searches, delegate to the PPI::Document
96 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 97 return $self->{_doc}->find_first($wanted, @more_args);
fb21e21e
CD
98 }
99
100 my $result = $self->find($wanted);
101 return $result ? $result->[0] : $result;
102}
103
6036a254 104#-----------------------------------------------------------------------------
fb21e21e 105
f5eeac3b 106sub find_any {
6e7d6c9f 107 my ($self, $wanted, @more_args) = @_;
f5eeac3b
CD
108
109 # This method can only find elements by their class names. For
110 # other types of searches, delegate to the PPI::Document
111 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 112 return $self->{_doc}->find_any($wanted, @more_args);
f5eeac3b
CD
113 }
114
115 my $result = $self->find($wanted);
116 return $result ? 1 : $result;
117}
118
6036a254 119#-----------------------------------------------------------------------------
f5eeac3b 120
60108aef
CD
121sub filename {
122 my ($self) = @_;
123 return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
124}
125
6036a254 126#-----------------------------------------------------------------------------
60108aef 127
267b39b4
ES
128sub highest_explicit_perl_version {
129 my ($self) = @_;
130
131 my $highest_explicit_perl_version =
132 $self->{_highest_explicit_perl_version};
133
134 if ( not exists $self->{_highest_explicit_perl_version} ) {
135 my $includes = $self->find( \&_is_a_version_statement );
136
137 if ($includes) {
138 $highest_explicit_perl_version =
139 max map { version->new( $_->version() ) } @{$includes};
140 }
141 else {
142 $highest_explicit_perl_version = undef;
143 }
144
145 $self->{_highest_explicit_perl_version} =
146 $highest_explicit_perl_version;
147 }
148
149 return $highest_explicit_perl_version if $highest_explicit_perl_version;
150 return;
151}
152
153sub _is_a_version_statement {
154 my (undef, $element) = @_;
155
156 return 0 if not $element->isa('PPI::Statement::Include');
157 return 1 if $element->version();
158 return 0;
159}
160
161#-----------------------------------------------------------------------------
162
58a9e587
JRT
163sub _caching_finder {
164
165 my $cache_ref = shift; # These vars will persist for the life
166 my %isa_cache = (); # of the code ref that this sub returns
167
168
169 # Gather up all the PPI elements and sort by @ISA. Note: if any
170 # instances used multiple inheritance, this implementation would
171 # lead to multiple copies of $element in the $elements_of lists.
172 # However, PPI::* doesn't do multiple inheritance, so we are safe
173
174 return sub {
6e7d6c9f 175 my (undef, $element) = @_;
58a9e587
JRT
176 my $classes = $isa_cache{ref $element};
177 if ( !$classes ) {
178 $classes = [ ref $element ];
179 # Use a C-style loop because we append to the classes array inside
180 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
181 no strict 'refs'; ## no critic(ProhibitNoStrict)
182 push @{$classes}, @{"$classes->[$i]::ISA"};
183 $cache_ref->{$classes->[$i]} ||= [];
5bf96118 184 }
58a9e587
JRT
185 $isa_cache{$classes->[0]} = $classes;
186 }
5bf96118 187
58a9e587
JRT
188 for my $class ( @{$classes} ) {
189 push @{$cache_ref->{$class}}, $element;
190 }
5bf96118 191
58a9e587
JRT
192 return 0; # 0 tells find() to keep traversing, but not to store this $element
193 };
5bf96118
CD
194}
195
6036a254 196#-----------------------------------------------------------------------------
58a9e587 197
5bf96118 1981;
58a9e587 199
5bf96118
CD
200__END__
201
a73f4a71
JRT
202=pod
203
204=for stopwords pre-caches
205
5bf96118
CD
206=head1 NAME
207
c728943a 208Perl::Critic::Document - Caching wrapper around a PPI::Document.
5bf96118 209
267b39b4 210
5bf96118
CD
211=head1 SYNOPSIS
212
213 use PPI::Document;
214 use Perl::Critic::Document;
215 my $doc = PPI::Document->new('Foo.pm');
216 $doc = Perl::Critic::Document->new($doc);
217 ## Then use the instance just like a PPI::Document
218
267b39b4 219
5bf96118
CD
220=head1 DESCRIPTION
221
222Perl::Critic does a lot of iterations over the PPI document tree via
223the C<PPI::Document::find()> method. To save some time, this class
224pre-caches a lot of the common C<find()> calls in a single traversal.
225Then, on subsequent requests we return the cached data.
226
227This is implemented as a facade, where method calls are handed to the
228stored C<PPI::Document> instance.
229
267b39b4 230
5bf96118
CD
231=head1 CAVEATS
232
233This facade does not implement the overloaded operators from
11f53956
ES
234L<PPI::Document|PPI::Document> (that is, the C<use overload ...>
235work). Therefore, users of this facade must not rely on that syntactic
236sugar. So, for example, instead of C<my $source = "$doc";> you should
237write C<my $source = $doc->content();>
5bf96118
CD
238
239Perhaps there is a CPAN module out there which implements a facade
240better than we do here?
241
267b39b4
ES
242
243=head1 CONSTRUCTOR
244
245=over
246
247=item C<< new($doc) >>
248
249Create a new instance referencing a PPI::Document instance.
250
251
252=back
253
254
5bf96118
CD
255=head1 METHODS
256
257=over
258
267b39b4 259=item C<< new($doc) >>
7076e807
CD
260
261Create a new instance referencing a PPI::Document instance.
262
267b39b4
ES
263
264=item C<< ppi_document() >>
2b6293b2 265
11f53956
ES
266Accessor for the wrapped PPI::Document instance. Note that altering
267this instance in any way can cause unpredictable failures in
268Perl::Critic's subsequent analysis because some caches may fall out of
269date.
2b6293b2 270
5bf96118 271
267b39b4
ES
272=item C<< find($wanted) >>
273
274=item C<< find_first($wanted) >>
fb21e21e 275
267b39b4 276=item C<< find_any($wanted) >>
f5eeac3b 277
fb21e21e 278If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
279Otherwise we forward the call to the corresponding method of the
280C<PPI::Document> instance.
5bf96118 281
267b39b4
ES
282
283=item C<< filename() >>
e7f2d995
CD
284
285Returns the filename for the source code if applicable
286(PPI::Document::File) or C<undef> otherwise (PPI::Document).
287
267b39b4
ES
288
289=item C<< isa( $classname ) >>
242f7b08 290
11f53956
ES
291To be compatible with other modules that expect to get a
292PPI::Document, the Perl::Critic::Document class masquerades as the
293PPI::Document class.
242f7b08 294
267b39b4
ES
295
296=item C<< highest_explicit_perl_version() >>
297
11f53956
ES
298Returns a L<version|version> object for the highest Perl version
299requirement declared in the document via a C<use> or C<require>
300statement. Returns nothing if there is no version statement.
267b39b4
ES
301
302
5bf96118
CD
303=back
304
267b39b4 305
5bf96118
CD
306=head1 AUTHOR
307
308Chris Dolan <cdolan@cpan.org>
309
267b39b4 310
5bf96118
CD
311=head1 COPYRIGHT
312
20dfddeb 313Copyright (c) 2006-2008 Chris Dolan. All rights reserved.
5bf96118
CD
314
315This program is free software; you can redistribute it and/or modify
316it under the same terms as Perl itself. The full text of this license
317can be found in the LICENSE file included with this module.
318
319=cut
737d3b65
CD
320
321# Local Variables:
322# mode: cperl
323# cperl-indent-level: 4
324# fill-column: 78
325# indent-tabs-mode: nil
326# c-indentation-style: bsd
327# End:
96fed375 328# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :