Commit | Line | Data |
---|---|---|
6036a254 | 1 | ############################################################################## |
a73f4a71 JRT |
2 | # $URL$ |
3 | # $Date$ | |
4 | # $Author$ | |
5 | # $Revision$ | |
6036a254 | 6 | ############################################################################## |
5bf96118 CD |
7 | |
8 | package Perl::Critic::Document; | |
9 | ||
df6dee2b | 10 | use 5.006001; |
5bf96118 | 11 | use strict; |
58a9e587 | 12 | use warnings; |
267b39b4 ES |
13 | |
14 | use List::Util qw< max >; | |
5bf96118 | 15 | use PPI::Document; |
267b39b4 ES |
16 | use Scalar::Util qw< weaken >; |
17 | use version; | |
5bf96118 | 18 | |
6036a254 | 19 | #----------------------------------------------------------------------------- |
58a9e587 | 20 | |
173667ce | 21 | our $VERSION = '1.093_01'; |
5bf96118 | 22 | |
6036a254 | 23 | #----------------------------------------------------------------------------- |
5bf96118 CD |
24 | |
25 | our $AUTOLOAD; | |
6e7d6c9f CD |
26 | sub 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 |
35 | sub new { |
36 | my ($class, $doc) = @_; | |
5bf96118 CD |
37 | return bless { _doc => $doc }, $class; |
38 | } | |
39 | ||
6036a254 | 40 | #----------------------------------------------------------------------------- |
58a9e587 | 41 | |
2b6293b2 CD |
42 | sub ppi_document { |
43 | my ($self) = @_; | |
44 | return $self->{_doc}; | |
45 | } | |
46 | ||
47 | #----------------------------------------------------------------------------- | |
48 | ||
47e1ff34 | 49 | sub 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 | 57 | sub 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 | 91 | sub 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 | 106 | sub 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 |
121 | sub filename { |
122 | my ($self) = @_; | |
123 | return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef; | |
124 | } | |
125 | ||
6036a254 | 126 | #----------------------------------------------------------------------------- |
60108aef | 127 | |
267b39b4 ES |
128 | sub 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) { | |
1ebef5a9 ES |
138 | # Note: this will complain about underscores, e.g. "use |
139 | # 5.008_000". However, nothing important should be depending upon | |
140 | # alpha perl versions and marking non-alpha versions as alpha is | |
141 | # bad in and of itself. Note that this contradicts an example in | |
142 | # perlfunc about "use". | |
267b39b4 ES |
143 | $highest_explicit_perl_version = |
144 | max map { version->new( $_->version() ) } @{$includes}; | |
145 | } | |
146 | else { | |
147 | $highest_explicit_perl_version = undef; | |
148 | } | |
149 | ||
150 | $self->{_highest_explicit_perl_version} = | |
151 | $highest_explicit_perl_version; | |
152 | } | |
153 | ||
154 | return $highest_explicit_perl_version if $highest_explicit_perl_version; | |
155 | return; | |
156 | } | |
157 | ||
158 | sub _is_a_version_statement { | |
159 | my (undef, $element) = @_; | |
160 | ||
161 | return 0 if not $element->isa('PPI::Statement::Include'); | |
162 | return 1 if $element->version(); | |
163 | return 0; | |
164 | } | |
165 | ||
166 | #----------------------------------------------------------------------------- | |
167 | ||
58a9e587 JRT |
168 | sub _caching_finder { |
169 | ||
170 | my $cache_ref = shift; # These vars will persist for the life | |
171 | my %isa_cache = (); # of the code ref that this sub returns | |
172 | ||
173 | ||
174 | # Gather up all the PPI elements and sort by @ISA. Note: if any | |
175 | # instances used multiple inheritance, this implementation would | |
176 | # lead to multiple copies of $element in the $elements_of lists. | |
177 | # However, PPI::* doesn't do multiple inheritance, so we are safe | |
178 | ||
179 | return sub { | |
6e7d6c9f | 180 | my (undef, $element) = @_; |
58a9e587 JRT |
181 | my $classes = $isa_cache{ref $element}; |
182 | if ( !$classes ) { | |
183 | $classes = [ ref $element ]; | |
184 | # Use a C-style loop because we append to the classes array inside | |
185 | for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops) | |
186 | no strict 'refs'; ## no critic(ProhibitNoStrict) | |
187 | push @{$classes}, @{"$classes->[$i]::ISA"}; | |
188 | $cache_ref->{$classes->[$i]} ||= []; | |
5bf96118 | 189 | } |
58a9e587 JRT |
190 | $isa_cache{$classes->[0]} = $classes; |
191 | } | |
5bf96118 | 192 | |
58a9e587 JRT |
193 | for my $class ( @{$classes} ) { |
194 | push @{$cache_ref->{$class}}, $element; | |
195 | } | |
5bf96118 | 196 | |
58a9e587 JRT |
197 | return 0; # 0 tells find() to keep traversing, but not to store this $element |
198 | }; | |
5bf96118 CD |
199 | } |
200 | ||
6036a254 | 201 | #----------------------------------------------------------------------------- |
58a9e587 | 202 | |
5bf96118 | 203 | 1; |
58a9e587 | 204 | |
5bf96118 CD |
205 | __END__ |
206 | ||
a73f4a71 JRT |
207 | =pod |
208 | ||
209 | =for stopwords pre-caches | |
210 | ||
5bf96118 CD |
211 | =head1 NAME |
212 | ||
c728943a | 213 | Perl::Critic::Document - Caching wrapper around a PPI::Document. |
5bf96118 | 214 | |
267b39b4 | 215 | |
5bf96118 CD |
216 | =head1 SYNOPSIS |
217 | ||
218 | use PPI::Document; | |
219 | use Perl::Critic::Document; | |
220 | my $doc = PPI::Document->new('Foo.pm'); | |
221 | $doc = Perl::Critic::Document->new($doc); | |
222 | ## Then use the instance just like a PPI::Document | |
223 | ||
267b39b4 | 224 | |
5bf96118 CD |
225 | =head1 DESCRIPTION |
226 | ||
227 | Perl::Critic does a lot of iterations over the PPI document tree via | |
228 | the C<PPI::Document::find()> method. To save some time, this class | |
229 | pre-caches a lot of the common C<find()> calls in a single traversal. | |
230 | Then, on subsequent requests we return the cached data. | |
231 | ||
232 | This is implemented as a facade, where method calls are handed to the | |
233 | stored C<PPI::Document> instance. | |
234 | ||
267b39b4 | 235 | |
5bf96118 CD |
236 | =head1 CAVEATS |
237 | ||
238 | This facade does not implement the overloaded operators from | |
11f53956 ES |
239 | L<PPI::Document|PPI::Document> (that is, the C<use overload ...> |
240 | work). Therefore, users of this facade must not rely on that syntactic | |
241 | sugar. So, for example, instead of C<my $source = "$doc";> you should | |
242 | write C<my $source = $doc->content();> | |
5bf96118 CD |
243 | |
244 | Perhaps there is a CPAN module out there which implements a facade | |
245 | better than we do here? | |
246 | ||
267b39b4 ES |
247 | |
248 | =head1 CONSTRUCTOR | |
249 | ||
250 | =over | |
251 | ||
252 | =item C<< new($doc) >> | |
253 | ||
254 | Create a new instance referencing a PPI::Document instance. | |
255 | ||
256 | ||
257 | =back | |
258 | ||
259 | ||
5bf96118 CD |
260 | =head1 METHODS |
261 | ||
262 | =over | |
263 | ||
267b39b4 | 264 | =item C<< new($doc) >> |
7076e807 CD |
265 | |
266 | Create a new instance referencing a PPI::Document instance. | |
267 | ||
267b39b4 ES |
268 | |
269 | =item C<< ppi_document() >> | |
2b6293b2 | 270 | |
11f53956 ES |
271 | Accessor for the wrapped PPI::Document instance. Note that altering |
272 | this instance in any way can cause unpredictable failures in | |
273 | Perl::Critic's subsequent analysis because some caches may fall out of | |
274 | date. | |
2b6293b2 | 275 | |
5bf96118 | 276 | |
267b39b4 ES |
277 | =item C<< find($wanted) >> |
278 | ||
279 | =item C<< find_first($wanted) >> | |
fb21e21e | 280 | |
267b39b4 | 281 | =item C<< find_any($wanted) >> |
f5eeac3b | 282 | |
fb21e21e | 283 | If C<$wanted> is a simple PPI class name, then the cache is employed. |
f5eeac3b CD |
284 | Otherwise we forward the call to the corresponding method of the |
285 | C<PPI::Document> instance. | |
5bf96118 | 286 | |
267b39b4 ES |
287 | |
288 | =item C<< filename() >> | |
e7f2d995 CD |
289 | |
290 | Returns the filename for the source code if applicable | |
291 | (PPI::Document::File) or C<undef> otherwise (PPI::Document). | |
292 | ||
267b39b4 ES |
293 | |
294 | =item C<< isa( $classname ) >> | |
242f7b08 | 295 | |
11f53956 ES |
296 | To be compatible with other modules that expect to get a |
297 | PPI::Document, the Perl::Critic::Document class masquerades as the | |
298 | PPI::Document class. | |
242f7b08 | 299 | |
267b39b4 ES |
300 | |
301 | =item C<< highest_explicit_perl_version() >> | |
302 | ||
11f53956 ES |
303 | Returns a L<version|version> object for the highest Perl version |
304 | requirement declared in the document via a C<use> or C<require> | |
305 | statement. Returns nothing if there is no version statement. | |
267b39b4 ES |
306 | |
307 | ||
5bf96118 CD |
308 | =back |
309 | ||
267b39b4 | 310 | |
5bf96118 CD |
311 | =head1 AUTHOR |
312 | ||
313 | Chris Dolan <cdolan@cpan.org> | |
314 | ||
267b39b4 | 315 | |
5bf96118 CD |
316 | =head1 COPYRIGHT |
317 | ||
20dfddeb | 318 | Copyright (c) 2006-2008 Chris Dolan. All rights reserved. |
5bf96118 CD |
319 | |
320 | This program is free software; you can redistribute it and/or modify | |
321 | it under the same terms as Perl itself. The full text of this license | |
322 | can be found in the LICENSE file included with this module. | |
323 | ||
324 | =cut | |
737d3b65 CD |
325 | |
326 | # Local Variables: | |
327 | # mode: cperl | |
328 | # cperl-indent-level: 4 | |
329 | # fill-column: 78 | |
330 | # indent-tabs-mode: nil | |
331 | # c-indentation-style: bsd | |
332 | # End: | |
96fed375 | 333 | # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : |