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