Login
Reduce B::Keywords to a recommendation, since it's absense is not
[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
b22c8627
JRT
16our $VERSION = '0.18_01';
17$VERSION = eval $VERSION; ## no critic
5bf96118
CD
18
19#----------------------------------------------------------------------------
20
21our $AUTOLOAD;
22sub AUTOLOAD { ## no critic(ProhibitAutoloading)
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(@_);
27}
28
58a9e587 29#----------------------------------------------------------------------------
5bf96118 30
58a9e587
JRT
31sub new {
32 my ($class, $doc) = @_;
5bf96118
CD
33 return bless { _doc => $doc }, $class;
34}
35
58a9e587
JRT
36#----------------------------------------------------------------------------
37
5bf96118 38sub find {
58a9e587 39 my ($self, $wanted) = @_;
5bf96118 40
58a9e587
JRT
41 # This method can only find elements by their class names. For
42 # other types of searches, delegate to the PPI::Document
5bf96118
CD
43 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
44 return $self->{_doc}->find($wanted, @_);
45 }
58a9e587
JRT
46
47 # Build the class cache if it doesn't exist. This happens at most
48 # once per Perl::Critic::Document instance. %elements of will be
49 # populated as a side-effect of calling the $finder_sub coderef
50 # that is produced by the caching_finder() closure.
5bf96118 51 if ( !$self->{_elements_of} ) {
58a9e587
JRT
52 my %cache = ( 'PPI::Document' => [ $self ] );
53 my $finder_coderef = _caching_finder( \%cache );
54 $self->{_doc}->find( $finder_coderef );
55 $self->{_elements_of} = \%cache;
56 }
57
58 # find() must return false-but-defined on fail
59 return $self->{_elements_of}->{$wanted} || q{};
60}
61
62#----------------------------------------------------------------------------
63
fb21e21e
CD
64sub find_first {
65 my ($self, $wanted) = @_;
66
67 # This method can only find elements by their class names. For
68 # other types of searches, delegate to the PPI::Document
69 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
70 return $self->{_doc}->find_first($wanted, @_);
71 }
72
73 my $result = $self->find($wanted);
74 return $result ? $result->[0] : $result;
75}
76
77#----------------------------------------------------------------------------
78
58a9e587
JRT
79sub _caching_finder {
80
81 my $cache_ref = shift; # These vars will persist for the life
82 my %isa_cache = (); # of the code ref that this sub returns
83
84
85 # Gather up all the PPI elements and sort by @ISA. Note: if any
86 # instances used multiple inheritance, this implementation would
87 # lead to multiple copies of $element in the $elements_of lists.
88 # However, PPI::* doesn't do multiple inheritance, so we are safe
89
90 return sub {
91 my $element = $_[1];
92 my $classes = $isa_cache{ref $element};
93 if ( !$classes ) {
94 $classes = [ ref $element ];
95 # Use a C-style loop because we append to the classes array inside
96 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
97 no strict 'refs'; ## no critic(ProhibitNoStrict)
98 push @{$classes}, @{"$classes->[$i]::ISA"};
99 $cache_ref->{$classes->[$i]} ||= [];
5bf96118 100 }
58a9e587
JRT
101 $isa_cache{$classes->[0]} = $classes;
102 }
5bf96118 103
58a9e587
JRT
104 for my $class ( @{$classes} ) {
105 push @{$cache_ref->{$class}}, $element;
106 }
5bf96118 107
58a9e587
JRT
108 return 0; # 0 tells find() to keep traversing, but not to store this $element
109 };
5bf96118
CD
110}
111
58a9e587
JRT
112#----------------------------------------------------------------------------
113
5bf96118 1141;
58a9e587 115
5bf96118
CD
116__END__
117
a73f4a71
JRT
118=pod
119
120=for stopwords pre-caches
121
5bf96118
CD
122=head1 NAME
123
124Perl::Critic::Document - Caching wrapper around PPI::Document
125
126=head1 SYNOPSIS
127
128 use PPI::Document;
129 use Perl::Critic::Document;
130 my $doc = PPI::Document->new('Foo.pm');
131 $doc = Perl::Critic::Document->new($doc);
132 ## Then use the instance just like a PPI::Document
133
134=head1 DESCRIPTION
135
136Perl::Critic does a lot of iterations over the PPI document tree via
137the C<PPI::Document::find()> method. To save some time, this class
138pre-caches a lot of the common C<find()> calls in a single traversal.
139Then, on subsequent requests we return the cached data.
140
141This is implemented as a facade, where method calls are handed to the
142stored C<PPI::Document> instance.
143
144=head1 CAVEATS
145
146This facade does not implement the overloaded operators from
147L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
148users of this facade must not rely on that syntactic sugar. So, for
149example, instead of C<my $source = "$doc";> you should write C<my
150$source = $doc->content();>
151
152Perhaps there is a CPAN module out there which implements a facade
153better than we do here?
154
155=head1 METHODS
156
157=over
158
7076e807
CD
159=item $pkg->new($doc)
160
161Create a new instance referencing a PPI::Document instance.
162
5bf96118
CD
163=item $self->find($wanted)
164
fb21e21e
CD
165=item $self->find_first($wanted)
166
167If C<$wanted> is a simple PPI class name, then the cache is employed.
168Otherwise we forward the call to the C<find()> or C<find_first()>
169method of the C<PPI::Document> instance.
5bf96118
CD
170
171=back
172
173=head1 AUTHOR
174
175Chris Dolan <cdolan@cpan.org>
176
177=head1 COPYRIGHT
178
179Copyright (c) 2006 Chris Dolan. All rights reserved.
180
181This program is free software; you can redistribute it and/or modify
182it under the same terms as Perl itself. The full text of this license
183can be found in the LICENSE file included with this module.
184
185=cut