Login
Abstract the PPI::Document caching code into a wrapper class,
[gknop/Perl-Critic.git] / lib / Perl / Critic / Document.pm
CommitLineData
5bf96118
CD
1#######################################################################
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6########################################################################
7
8package Perl::Critic::Document;
9
10use warnings;
11use strict;
12use PPI::Document;
13
14our $VERSION = '0.18';
15$VERSION = eval $VERSION; ## no critic
16
17#----------------------------------------------------------------------------
18
19our $AUTOLOAD;
20sub AUTOLOAD { ## no critic(ProhibitAutoloading)
21 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
22 return if $function_name eq 'DESTROY';
23 my $self = shift;
24 return $self->{_doc}->$function_name(@_);
25}
26
27sub new {
28 my $class = shift;
29 my $doc = shift;
30
31 return bless { _doc => $doc }, $class;
32}
33
34sub find {
35 my $self = shift;
36 my $wanted = shift;
37
38 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
39 return $self->{_doc}->find($wanted, @_);
40 }
41
42 # Build the class cache if it doesn't exist
43 # This happens at most once per Perl::Critic::Document instance
44 if ( !$self->{_elements_of} ) {
45 my %elements_of = ( 'PPI::Document' => [ $self ] );
46
47 # Gather up all the PPI elements and sort by @ISA.
48 # Note: if any instances used multiple inheritance, this
49 # implementation would lead to multiple copies of $element
50 # in the $elements_of lists. However, PPI::* doesn't do
51 # multiple inheritance, so we are safe
52 my %isa_cache;
53 $self->{_doc}->find( sub {
54 my $element = $_[1];
55 my $classes = $isa_cache{ref $element};
56 if ( !$classes ) {
57 $classes = [ ref $element ];
58 # Use a C-style loop because we append to the classes array inside
59 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
60 no strict 'refs'; ## no critic(ProhibitNoStrict)
61 push @{$classes}, @{"$classes->[$i]::ISA"};
62 $elements_of{$classes->[$i]} ||= [];
63 }
64 $isa_cache{$classes->[0]} = $classes;
65 }
66 for my $class ( @{$classes} ) {
67 push @{$elements_of{$class}}, $element;
68 }
69 return 0; # 0 tells find() to keep traversing, but not to store this $element
70 } );
71
72 $self->{_elements_of} = \%elements_of;
73 }
74
75 return $self->{_elements_of}->{$wanted} || q{}; # find() must return false-but-defined on fail
76}
77
781;
79__END__
80
81=head1 NAME
82
83Perl::Critic::Document - Caching wrapper around PPI::Document
84
85=head1 SYNOPSIS
86
87 use PPI::Document;
88 use Perl::Critic::Document;
89 my $doc = PPI::Document->new('Foo.pm');
90 $doc = Perl::Critic::Document->new($doc);
91 ## Then use the instance just like a PPI::Document
92
93=head1 DESCRIPTION
94
95Perl::Critic does a lot of iterations over the PPI document tree via
96the C<PPI::Document::find()> method. To save some time, this class
97pre-caches a lot of the common C<find()> calls in a single traversal.
98Then, on subsequent requests we return the cached data.
99
100This is implemented as a facade, where method calls are handed to the
101stored C<PPI::Document> instance.
102
103=head1 CAVEATS
104
105This facade does not implement the overloaded operators from
106L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
107users of this facade must not rely on that syntactic sugar. So, for
108example, instead of C<my $source = "$doc";> you should write C<my
109$source = $doc->content();>
110
111Perhaps there is a CPAN module out there which implements a facade
112better than we do here?
113
114=head1 METHODS
115
116=over
117
118=item $self->find($wanted)
119
120If C<wanted> is a simple PPI class name, then the cache is employed.
121Otherwise we forward the call to the C<find()> method of the
122C<PPI::Document> instance.
123
124=back
125
126=head1 AUTHOR
127
128Chris Dolan <cdolan@cpan.org>
129
130=head1 COPYRIGHT
131
132Copyright (c) 2006 Chris Dolan. All rights reserved.
133
134This program is free software; you can redistribute it and/or modify
135it under the same terms as Perl itself. The full text of this license
136can be found in the LICENSE file included with this module.
137
138=cut