Commit | Line | Data |
---|---|---|
58a9e587 JRT |
1 | ######################################################################## |
2 | # $URL:$ | |
3 | # $Date:$ | |
4 | # $Author:$ | |
5 | # $Revision:$ | |
5bf96118 CD |
6 | ######################################################################## |
7 | ||
8 | package Perl::Critic::Document; | |
9 | ||
5bf96118 | 10 | use strict; |
58a9e587 | 11 | use warnings; |
5bf96118 CD |
12 | use PPI::Document; |
13 | ||
58a9e587 JRT |
14 | #---------------------------------------------------------------------------- |
15 | ||
b22c8627 JRT |
16 | our $VERSION = '0.18_01'; |
17 | $VERSION = eval $VERSION; ## no critic | |
5bf96118 CD |
18 | |
19 | #---------------------------------------------------------------------------- | |
20 | ||
21 | our $AUTOLOAD; | |
22 | sub 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 |
31 | sub new { |
32 | my ($class, $doc) = @_; | |
5bf96118 CD |
33 | return bless { _doc => $doc }, $class; |
34 | } | |
35 | ||
58a9e587 JRT |
36 | #---------------------------------------------------------------------------- |
37 | ||
5bf96118 | 38 | sub 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 | ||
64 | sub _caching_finder { | |
65 | ||
66 | my $cache_ref = shift; # These vars will persist for the life | |
67 | my %isa_cache = (); # of the code ref that this sub returns | |
68 | ||
69 | ||
70 | # Gather up all the PPI elements and sort by @ISA. Note: if any | |
71 | # instances used multiple inheritance, this implementation would | |
72 | # lead to multiple copies of $element in the $elements_of lists. | |
73 | # However, PPI::* doesn't do multiple inheritance, so we are safe | |
74 | ||
75 | return sub { | |
76 | my $element = $_[1]; | |
77 | my $classes = $isa_cache{ref $element}; | |
78 | if ( !$classes ) { | |
79 | $classes = [ ref $element ]; | |
80 | # Use a C-style loop because we append to the classes array inside | |
81 | for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops) | |
82 | no strict 'refs'; ## no critic(ProhibitNoStrict) | |
83 | push @{$classes}, @{"$classes->[$i]::ISA"}; | |
84 | $cache_ref->{$classes->[$i]} ||= []; | |
5bf96118 | 85 | } |
58a9e587 JRT |
86 | $isa_cache{$classes->[0]} = $classes; |
87 | } | |
5bf96118 | 88 | |
58a9e587 JRT |
89 | for my $class ( @{$classes} ) { |
90 | push @{$cache_ref->{$class}}, $element; | |
91 | } | |
5bf96118 | 92 | |
58a9e587 JRT |
93 | return 0; # 0 tells find() to keep traversing, but not to store this $element |
94 | }; | |
5bf96118 CD |
95 | } |
96 | ||
58a9e587 JRT |
97 | #---------------------------------------------------------------------------- |
98 | ||
5bf96118 | 99 | 1; |
58a9e587 | 100 | |
5bf96118 CD |
101 | __END__ |
102 | ||
103 | =head1 NAME | |
104 | ||
105 | Perl::Critic::Document - Caching wrapper around PPI::Document | |
106 | ||
107 | =head1 SYNOPSIS | |
108 | ||
109 | use PPI::Document; | |
110 | use Perl::Critic::Document; | |
111 | my $doc = PPI::Document->new('Foo.pm'); | |
112 | $doc = Perl::Critic::Document->new($doc); | |
113 | ## Then use the instance just like a PPI::Document | |
114 | ||
115 | =head1 DESCRIPTION | |
116 | ||
117 | Perl::Critic does a lot of iterations over the PPI document tree via | |
118 | the C<PPI::Document::find()> method. To save some time, this class | |
119 | pre-caches a lot of the common C<find()> calls in a single traversal. | |
120 | Then, on subsequent requests we return the cached data. | |
121 | ||
122 | This is implemented as a facade, where method calls are handed to the | |
123 | stored C<PPI::Document> instance. | |
124 | ||
125 | =head1 CAVEATS | |
126 | ||
127 | This facade does not implement the overloaded operators from | |
128 | L<PPI::Document> (that is, the C<use overload ...> work). Therefore, | |
129 | users of this facade must not rely on that syntactic sugar. So, for | |
130 | example, instead of C<my $source = "$doc";> you should write C<my | |
131 | $source = $doc->content();> | |
132 | ||
133 | Perhaps there is a CPAN module out there which implements a facade | |
134 | better than we do here? | |
135 | ||
136 | =head1 METHODS | |
137 | ||
138 | =over | |
139 | ||
140 | =item $self->find($wanted) | |
141 | ||
142 | If C<wanted> is a simple PPI class name, then the cache is employed. | |
143 | Otherwise we forward the call to the C<find()> method of the | |
144 | C<PPI::Document> instance. | |
145 | ||
146 | =back | |
147 | ||
148 | =head1 AUTHOR | |
149 | ||
150 | Chris Dolan <cdolan@cpan.org> | |
151 | ||
152 | =head1 COPYRIGHT | |
153 | ||
154 | Copyright (c) 2006 Chris Dolan. All rights reserved. | |
155 | ||
156 | This program is free software; you can redistribute it and/or modify | |
157 | it under the same terms as Perl itself. The full text of this license | |
158 | can be found in the LICENSE file included with this module. | |
159 | ||
160 | =cut |