Login
Fixed memory leak. See comments for details.
[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
5bf96118 10use strict;
58a9e587 11use warnings;
5bf96118
CD
12use PPI::Document;
13
6036a254 14#-----------------------------------------------------------------------------
58a9e587 15
16cfe89e 16our $VERSION = 1.01;
5bf96118 17
6036a254 18#-----------------------------------------------------------------------------
5bf96118
CD
19
20our $AUTOLOAD;
21sub 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
6036a254 28#-----------------------------------------------------------------------------
5bf96118 29
58a9e587
JRT
30sub new {
31 my ($class, $doc) = @_;
5bf96118
CD
32 return bless { _doc => $doc }, $class;
33}
34
6036a254 35#-----------------------------------------------------------------------------
58a9e587 36
47e1ff34
CD
37sub isa {
38 my $self = shift;
242f7b08
JRT
39 return $self->SUPER::isa(@_)
40 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@_) );
47e1ff34
CD
41}
42
6036a254 43#-----------------------------------------------------------------------------
47e1ff34 44
5bf96118 45sub 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
6036a254 69#-----------------------------------------------------------------------------
58a9e587 70
fb21e21e
CD
71sub 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
6036a254 84#-----------------------------------------------------------------------------
fb21e21e 85
f5eeac3b
CD
86sub 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
6036a254 99#-----------------------------------------------------------------------------
f5eeac3b 100
60108aef
CD
101sub filename {
102 my ($self) = @_;
103 return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
104}
105
6036a254 106#-----------------------------------------------------------------------------
60108aef 107
58a9e587
JRT
108sub _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
6036a254 141#-----------------------------------------------------------------------------
58a9e587 142
5bf96118 1431;
58a9e587 144
5bf96118
CD
145__END__
146
a73f4a71
JRT
147=pod
148
149=for stopwords pre-caches
150
5bf96118
CD
151=head1 NAME
152
153Perl::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
165Perl::Critic does a lot of iterations over the PPI document tree via
166the C<PPI::Document::find()> method. To save some time, this class
167pre-caches a lot of the common C<find()> calls in a single traversal.
168Then, on subsequent requests we return the cached data.
169
170This is implemented as a facade, where method calls are handed to the
171stored C<PPI::Document> instance.
172
173=head1 CAVEATS
174
175This facade does not implement the overloaded operators from
176L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
177users of this facade must not rely on that syntactic sugar. So, for
178example, instead of C<my $source = "$doc";> you should write C<my
179$source = $doc->content();>
180
181Perhaps there is a CPAN module out there which implements a facade
182better than we do here?
183
184=head1 METHODS
185
186=over
187
7076e807
CD
188=item $pkg->new($doc)
189
190Create 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 198If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
199Otherwise we forward the call to the corresponding method of the
200C<PPI::Document> instance.
5bf96118 201
e7f2d995
CD
202=item $self->filename()
203
204Returns 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
209To be compatible with other modules that expect to get a PPI::Document, the
8a25c8a0 210Perl::Critic::Document class masquerades as the PPI::Document class.
242f7b08 211
5bf96118
CD
212=back
213
214=head1 AUTHOR
215
216Chris Dolan <cdolan@cpan.org>
217
218=head1 COPYRIGHT
219
220Copyright (c) 2006 Chris Dolan. All rights reserved.
221
222This program is free software; you can redistribute it and/or modify
223it under the same terms as Perl itself. The full text of this license
224can 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 :