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