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 | ||
5bf96118 | 10 | use strict; |
58a9e587 | 11 | use warnings; |
5bf96118 | 12 | use PPI::Document; |
389109ec | 13 | use Scalar::Util qw(weaken); |
5bf96118 | 14 | |
6036a254 | 15 | #----------------------------------------------------------------------------- |
58a9e587 | 16 | |
e858ba92 | 17 | our $VERSION = 1.06; |
5bf96118 | 18 | |
6036a254 | 19 | #----------------------------------------------------------------------------- |
5bf96118 CD |
20 | |
21 | our $AUTOLOAD; | |
22 | sub AUTOLOAD { ## no critic(ProhibitAutoloading) | |
23 | my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms; | |
24 | return if $function_name eq 'DESTROY'; | |
25 | my $self = shift; | |
26 | return $self->{_doc}->$function_name(@_); | |
27 | } | |
28 | ||
6036a254 | 29 | #----------------------------------------------------------------------------- |
5bf96118 | 30 | |
58a9e587 JRT |
31 | sub new { |
32 | my ($class, $doc) = @_; | |
5bf96118 CD |
33 | return bless { _doc => $doc }, $class; |
34 | } | |
35 | ||
6036a254 | 36 | #----------------------------------------------------------------------------- |
58a9e587 | 37 | |
47e1ff34 CD |
38 | sub isa { |
39 | my $self = shift; | |
242f7b08 JRT |
40 | return $self->SUPER::isa(@_) |
41 | || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@_) ); | |
47e1ff34 CD |
42 | } |
43 | ||
6036a254 | 44 | #----------------------------------------------------------------------------- |
47e1ff34 | 45 | |
5bf96118 | 46 | sub find { |
58a9e587 | 47 | my ($self, $wanted) = @_; |
5bf96118 | 48 | |
58a9e587 JRT |
49 | # This method can only find elements by their class names. For |
50 | # other types of searches, delegate to the PPI::Document | |
5bf96118 CD |
51 | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { |
52 | return $self->{_doc}->find($wanted, @_); | |
53 | } | |
58a9e587 JRT |
54 | |
55 | # Build the class cache if it doesn't exist. This happens at most | |
56 | # once per Perl::Critic::Document instance. %elements of will be | |
57 | # populated as a side-effect of calling the $finder_sub coderef | |
58 | # that is produced by the caching_finder() closure. | |
5bf96118 | 59 | if ( !$self->{_elements_of} ) { |
389109ec | 60 | |
58a9e587 | 61 | my %cache = ( 'PPI::Document' => [ $self ] ); |
389109ec JRT |
62 | |
63 | # The cache refers to $self, and $self refers to the cache. This | |
64 | # creates a circular reference that leaks memory (i.e. $self is not | |
65 | # destroyed until execution is complete). By weakening the reference, | |
66 | # we allow perl to collect the garbage properly. | |
67 | weaken( $cache{'PPI::Document'}->[0] ); | |
68 | ||
58a9e587 JRT |
69 | my $finder_coderef = _caching_finder( \%cache ); |
70 | $self->{_doc}->find( $finder_coderef ); | |
71 | $self->{_elements_of} = \%cache; | |
72 | } | |
73 | ||
74 | # find() must return false-but-defined on fail | |
75 | return $self->{_elements_of}->{$wanted} || q{}; | |
76 | } | |
77 | ||
6036a254 | 78 | #----------------------------------------------------------------------------- |
58a9e587 | 79 | |
fb21e21e CD |
80 | sub find_first { |
81 | my ($self, $wanted) = @_; | |
82 | ||
83 | # This method can only find elements by their class names. For | |
84 | # other types of searches, delegate to the PPI::Document | |
85 | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | |
86 | return $self->{_doc}->find_first($wanted, @_); | |
87 | } | |
88 | ||
89 | my $result = $self->find($wanted); | |
90 | return $result ? $result->[0] : $result; | |
91 | } | |
92 | ||
6036a254 | 93 | #----------------------------------------------------------------------------- |
fb21e21e | 94 | |
f5eeac3b CD |
95 | sub find_any { |
96 | my ($self, $wanted) = @_; | |
97 | ||
98 | # This method can only find elements by their class names. For | |
99 | # other types of searches, delegate to the PPI::Document | |
100 | if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { | |
101 | return $self->{_doc}->find_any($wanted, @_); | |
102 | } | |
103 | ||
104 | my $result = $self->find($wanted); | |
105 | return $result ? 1 : $result; | |
106 | } | |
107 | ||
6036a254 | 108 | #----------------------------------------------------------------------------- |
f5eeac3b | 109 | |
60108aef CD |
110 | sub filename { |
111 | my ($self) = @_; | |
112 | return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef; | |
113 | } | |
114 | ||
6036a254 | 115 | #----------------------------------------------------------------------------- |
60108aef | 116 | |
58a9e587 JRT |
117 | sub _caching_finder { |
118 | ||
119 | my $cache_ref = shift; # These vars will persist for the life | |
120 | my %isa_cache = (); # of the code ref that this sub returns | |
121 | ||
122 | ||
123 | # Gather up all the PPI elements and sort by @ISA. Note: if any | |
124 | # instances used multiple inheritance, this implementation would | |
125 | # lead to multiple copies of $element in the $elements_of lists. | |
126 | # However, PPI::* doesn't do multiple inheritance, so we are safe | |
127 | ||
128 | return sub { | |
129 | my $element = $_[1]; | |
130 | my $classes = $isa_cache{ref $element}; | |
131 | if ( !$classes ) { | |
132 | $classes = [ ref $element ]; | |
133 | # Use a C-style loop because we append to the classes array inside | |
134 | for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops) | |
135 | no strict 'refs'; ## no critic(ProhibitNoStrict) | |
136 | push @{$classes}, @{"$classes->[$i]::ISA"}; | |
137 | $cache_ref->{$classes->[$i]} ||= []; | |
5bf96118 | 138 | } |
58a9e587 JRT |
139 | $isa_cache{$classes->[0]} = $classes; |
140 | } | |
5bf96118 | 141 | |
58a9e587 JRT |
142 | for my $class ( @{$classes} ) { |
143 | push @{$cache_ref->{$class}}, $element; | |
144 | } | |
5bf96118 | 145 | |
58a9e587 JRT |
146 | return 0; # 0 tells find() to keep traversing, but not to store this $element |
147 | }; | |
5bf96118 CD |
148 | } |
149 | ||
6036a254 | 150 | #----------------------------------------------------------------------------- |
58a9e587 | 151 | |
5bf96118 | 152 | 1; |
58a9e587 | 153 | |
5bf96118 CD |
154 | __END__ |
155 | ||
a73f4a71 JRT |
156 | =pod |
157 | ||
158 | =for stopwords pre-caches | |
159 | ||
5bf96118 CD |
160 | =head1 NAME |
161 | ||
162 | Perl::Critic::Document - Caching wrapper around PPI::Document | |
163 | ||
164 | =head1 SYNOPSIS | |
165 | ||
166 | use PPI::Document; | |
167 | use Perl::Critic::Document; | |
168 | my $doc = PPI::Document->new('Foo.pm'); | |
169 | $doc = Perl::Critic::Document->new($doc); | |
170 | ## Then use the instance just like a PPI::Document | |
171 | ||
172 | =head1 DESCRIPTION | |
173 | ||
174 | Perl::Critic does a lot of iterations over the PPI document tree via | |
175 | the C<PPI::Document::find()> method. To save some time, this class | |
176 | pre-caches a lot of the common C<find()> calls in a single traversal. | |
177 | Then, on subsequent requests we return the cached data. | |
178 | ||
179 | This is implemented as a facade, where method calls are handed to the | |
180 | stored C<PPI::Document> instance. | |
181 | ||
182 | =head1 CAVEATS | |
183 | ||
184 | This facade does not implement the overloaded operators from | |
185 | L<PPI::Document> (that is, the C<use overload ...> work). Therefore, | |
186 | users of this facade must not rely on that syntactic sugar. So, for | |
187 | example, instead of C<my $source = "$doc";> you should write C<my | |
188 | $source = $doc->content();> | |
189 | ||
190 | Perhaps there is a CPAN module out there which implements a facade | |
191 | better than we do here? | |
192 | ||
193 | =head1 METHODS | |
194 | ||
195 | =over | |
196 | ||
7076e807 CD |
197 | =item $pkg->new($doc) |
198 | ||
199 | Create a new instance referencing a PPI::Document instance. | |
200 | ||
5bf96118 CD |
201 | =item $self->find($wanted) |
202 | ||
fb21e21e CD |
203 | =item $self->find_first($wanted) |
204 | ||
f5eeac3b CD |
205 | =item $self->find_any($wanted) |
206 | ||
fb21e21e | 207 | If C<$wanted> is a simple PPI class name, then the cache is employed. |
f5eeac3b CD |
208 | Otherwise we forward the call to the corresponding method of the |
209 | C<PPI::Document> instance. | |
5bf96118 | 210 | |
e7f2d995 CD |
211 | =item $self->filename() |
212 | ||
213 | Returns the filename for the source code if applicable | |
214 | (PPI::Document::File) or C<undef> otherwise (PPI::Document). | |
215 | ||
242f7b08 JRT |
216 | =item $self->isa( $classname ) |
217 | ||
218 | To be compatible with other modules that expect to get a PPI::Document, the | |
8a25c8a0 | 219 | Perl::Critic::Document class masquerades as the PPI::Document class. |
242f7b08 | 220 | |
5bf96118 CD |
221 | =back |
222 | ||
223 | =head1 AUTHOR | |
224 | ||
225 | Chris Dolan <cdolan@cpan.org> | |
226 | ||
227 | =head1 COPYRIGHT | |
228 | ||
229 | Copyright (c) 2006 Chris Dolan. All rights reserved. | |
230 | ||
231 | This program is free software; you can redistribute it and/or modify | |
232 | it under the same terms as Perl itself. The full text of this license | |
233 | can be found in the LICENSE file included with this module. | |
234 | ||
235 | =cut | |
737d3b65 CD |
236 | |
237 | # Local Variables: | |
238 | # mode: cperl | |
239 | # cperl-indent-level: 4 | |
240 | # fill-column: 78 | |
241 | # indent-tabs-mode: nil | |
242 | # c-indentation-style: bsd | |
243 | # End: | |
345c7562 | 244 | # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab : |