Login
Doc error: the config parameter stop_words was misspelled
[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
b4d9a58e 17our $VERSION = 1.078;
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
47e1ff34 38sub isa {
6e7d6c9f
CD
39 my ($self, @args) = @_;
40 return $self->SUPER::isa(@args)
41 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
47e1ff34
CD
42}
43
6036a254 44#-----------------------------------------------------------------------------
47e1ff34 45
5bf96118 46sub find {
6e7d6c9f 47 my ($self, $wanted, @more_args) = @_;
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 51 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 52 return $self->{_doc}->find($wanted, @more_args);
5bf96118 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 80sub find_first {
6e7d6c9f 81 my ($self, $wanted, @more_args) = @_;
fb21e21e
CD
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 ) {
6e7d6c9f 86 return $self->{_doc}->find_first($wanted, @more_args);
fb21e21e
CD
87 }
88
89 my $result = $self->find($wanted);
90 return $result ? $result->[0] : $result;
91}
92
6036a254 93#-----------------------------------------------------------------------------
fb21e21e 94
f5eeac3b 95sub find_any {
6e7d6c9f 96 my ($self, $wanted, @more_args) = @_;
f5eeac3b
CD
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 ) {
6e7d6c9f 101 return $self->{_doc}->find_any($wanted, @more_args);
f5eeac3b
CD
102 }
103
104 my $result = $self->find($wanted);
105 return $result ? 1 : $result;
106}
107
6036a254 108#-----------------------------------------------------------------------------
f5eeac3b 109
60108aef
CD
110sub filename {
111 my ($self) = @_;
112 return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
113}
114
6036a254 115#-----------------------------------------------------------------------------
60108aef 116
58a9e587
JRT
117sub _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 {
6e7d6c9f 129 my (undef, $element) = @_;
58a9e587
JRT
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 1521;
58a9e587 153
5bf96118
CD
154__END__
155
a73f4a71
JRT
156=pod
157
158=for stopwords pre-caches
159
5bf96118
CD
160=head1 NAME
161
162Perl::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
174Perl::Critic does a lot of iterations over the PPI document tree via
175the C<PPI::Document::find()> method. To save some time, this class
176pre-caches a lot of the common C<find()> calls in a single traversal.
177Then, on subsequent requests we return the cached data.
178
179This is implemented as a facade, where method calls are handed to the
180stored C<PPI::Document> instance.
181
182=head1 CAVEATS
183
184This facade does not implement the overloaded operators from
185L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
186users of this facade must not rely on that syntactic sugar. So, for
187example, instead of C<my $source = "$doc";> you should write C<my
188$source = $doc->content();>
189
190Perhaps there is a CPAN module out there which implements a facade
191better than we do here?
192
193=head1 METHODS
194
195=over
196
7076e807
CD
197=item $pkg->new($doc)
198
199Create 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 207If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
208Otherwise we forward the call to the corresponding method of the
209C<PPI::Document> instance.
5bf96118 210
e7f2d995
CD
211=item $self->filename()
212
213Returns 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
218To be compatible with other modules that expect to get a PPI::Document, the
8a25c8a0 219Perl::Critic::Document class masquerades as the PPI::Document class.
242f7b08 220
5bf96118
CD
221=back
222
223=head1 AUTHOR
224
225Chris Dolan <cdolan@cpan.org>
226
227=head1 COPYRIGHT
228
229Copyright (c) 2006 Chris Dolan. All rights reserved.
230
231This program is free software; you can redistribute it and/or modify
232it under the same terms as Perl itself. The full text of this license
233can 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 :