Login
Fix up a bunch of SVN properties: executable and keywords
[gknop/Perl-Critic.git] / lib / Perl / Critic / Document.pm
CommitLineData
58a9e587 1########################################################################
a73f4a71
JRT
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
5bf96118
CD
6########################################################################
7
8package Perl::Critic::Document;
9
5bf96118 10use strict;
58a9e587 11use warnings;
5bf96118
CD
12use PPI::Document;
13
58a9e587
JRT
14#----------------------------------------------------------------------------
15
14e65e8f 16our $VERSION = 0.20;
5bf96118 17
5315267e
CD
18# Fast...
19{
20 no warnings 'redefine'; ## no critic(ProhibitNoWarn)
21 *PPI::Node::content = sub {
22 return $_[0]->{_content} ||= join q{}, map { $_->content } @{$_[0]->{children}};
23 };
24}
25
26
5bf96118
CD
27#----------------------------------------------------------------------------
28
29our $AUTOLOAD;
30sub AUTOLOAD { ## no critic(ProhibitAutoloading)
31 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
32 return if $function_name eq 'DESTROY';
33 my $self = shift;
34 return $self->{_doc}->$function_name(@_);
35}
36
58a9e587 37#----------------------------------------------------------------------------
5bf96118 38
58a9e587
JRT
39sub new {
40 my ($class, $doc) = @_;
5bf96118
CD
41 return bless { _doc => $doc }, $class;
42}
43
58a9e587
JRT
44#----------------------------------------------------------------------------
45
5bf96118 46sub 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} ) {
58a9e587
JRT
60 my %cache = ( 'PPI::Document' => [ $self ] );
61 my $finder_coderef = _caching_finder( \%cache );
62 $self->{_doc}->find( $finder_coderef );
63 $self->{_elements_of} = \%cache;
64 }
65
66 # find() must return false-but-defined on fail
67 return $self->{_elements_of}->{$wanted} || q{};
68}
69
70#----------------------------------------------------------------------------
71
fb21e21e
CD
72sub find_first {
73 my ($self, $wanted) = @_;
74
75 # This method can only find elements by their class names. For
76 # other types of searches, delegate to the PPI::Document
77 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
78 return $self->{_doc}->find_first($wanted, @_);
79 }
80
81 my $result = $self->find($wanted);
82 return $result ? $result->[0] : $result;
83}
84
85#----------------------------------------------------------------------------
86
f5eeac3b
CD
87sub find_any {
88 my ($self, $wanted) = @_;
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 ) {
93 return $self->{_doc}->find_any($wanted, @_);
94 }
95
96 my $result = $self->find($wanted);
97 return $result ? 1 : $result;
98}
99
100#----------------------------------------------------------------------------
101
58a9e587
JRT
102sub _caching_finder {
103
104 my $cache_ref = shift; # These vars will persist for the life
105 my %isa_cache = (); # of the code ref that this sub returns
106
107
108 # Gather up all the PPI elements and sort by @ISA. Note: if any
109 # instances used multiple inheritance, this implementation would
110 # lead to multiple copies of $element in the $elements_of lists.
111 # However, PPI::* doesn't do multiple inheritance, so we are safe
112
113 return sub {
114 my $element = $_[1];
115 my $classes = $isa_cache{ref $element};
116 if ( !$classes ) {
117 $classes = [ ref $element ];
118 # Use a C-style loop because we append to the classes array inside
119 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
120 no strict 'refs'; ## no critic(ProhibitNoStrict)
121 push @{$classes}, @{"$classes->[$i]::ISA"};
122 $cache_ref->{$classes->[$i]} ||= [];
5bf96118 123 }
58a9e587
JRT
124 $isa_cache{$classes->[0]} = $classes;
125 }
5bf96118 126
58a9e587
JRT
127 for my $class ( @{$classes} ) {
128 push @{$cache_ref->{$class}}, $element;
129 }
5bf96118 130
58a9e587
JRT
131 return 0; # 0 tells find() to keep traversing, but not to store this $element
132 };
5bf96118
CD
133}
134
58a9e587
JRT
135#----------------------------------------------------------------------------
136
5bf96118 1371;
58a9e587 138
5bf96118
CD
139__END__
140
a73f4a71
JRT
141=pod
142
143=for stopwords pre-caches
144
5bf96118
CD
145=head1 NAME
146
147Perl::Critic::Document - Caching wrapper around PPI::Document
148
149=head1 SYNOPSIS
150
151 use PPI::Document;
152 use Perl::Critic::Document;
153 my $doc = PPI::Document->new('Foo.pm');
154 $doc = Perl::Critic::Document->new($doc);
155 ## Then use the instance just like a PPI::Document
156
157=head1 DESCRIPTION
158
159Perl::Critic does a lot of iterations over the PPI document tree via
160the C<PPI::Document::find()> method. To save some time, this class
161pre-caches a lot of the common C<find()> calls in a single traversal.
162Then, on subsequent requests we return the cached data.
163
164This is implemented as a facade, where method calls are handed to the
165stored C<PPI::Document> instance.
166
167=head1 CAVEATS
168
169This facade does not implement the overloaded operators from
170L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
171users of this facade must not rely on that syntactic sugar. So, for
172example, instead of C<my $source = "$doc";> you should write C<my
173$source = $doc->content();>
174
175Perhaps there is a CPAN module out there which implements a facade
176better than we do here?
177
178=head1 METHODS
179
180=over
181
7076e807
CD
182=item $pkg->new($doc)
183
184Create a new instance referencing a PPI::Document instance.
185
5bf96118
CD
186=item $self->find($wanted)
187
fb21e21e
CD
188=item $self->find_first($wanted)
189
f5eeac3b
CD
190=item $self->find_any($wanted)
191
fb21e21e 192If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
193Otherwise we forward the call to the corresponding method of the
194C<PPI::Document> instance.
5bf96118
CD
195
196=back
197
198=head1 AUTHOR
199
200Chris Dolan <cdolan@cpan.org>
201
202=head1 COPYRIGHT
203
204Copyright (c) 2006 Chris Dolan. All rights reserved.
205
206This program is free software; you can redistribute it and/or modify
207it under the same terms as Perl itself. The full text of this license
208can be found in the LICENSE file included with this module.
209
210=cut