1 ##############################################################################
2 # $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Document.pm $
3 # $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
6 ##############################################################################
8 package Perl::Critic::Document;
14 use List::Util qw< max >;
16 use Scalar::Util qw< weaken >;
19 #-----------------------------------------------------------------------------
21 our $VERSION = '1.088';
23 #-----------------------------------------------------------------------------
26 sub AUTOLOAD { ## no critic(ProhibitAutoloading,ArgUnpacking)
27 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
28 return if $function_name eq 'DESTROY';
30 return $self->{_doc}->$function_name(@_);
33 #-----------------------------------------------------------------------------
36 my ($class, $doc) = @_;
37 return bless { _doc => $doc }, $class;
40 #-----------------------------------------------------------------------------
47 #-----------------------------------------------------------------------------
50 my ($self, @args) = @_;
51 return $self->SUPER::isa(@args)
52 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
55 #-----------------------------------------------------------------------------
58 my ($self, $wanted, @more_args) = @_;
60 # This method can only find elements by their class names. For
61 # other types of searches, delegate to the PPI::Document
62 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
63 return $self->{_doc}->find($wanted, @more_args);
66 # Build the class cache if it doesn't exist. This happens at most
67 # once per Perl::Critic::Document instance. %elements of will be
68 # populated as a side-effect of calling the $finder_sub coderef
69 # that is produced by the caching_finder() closure.
70 if ( !$self->{_elements_of} ) {
72 my %cache = ( 'PPI::Document' => [ $self ] );
74 # The cache refers to $self, and $self refers to the cache. This
75 # creates a circular reference that leaks memory (i.e. $self is not
76 # destroyed until execution is complete). By weakening the reference,
77 # we allow perl to collect the garbage properly.
78 weaken( $cache{'PPI::Document'}->[0] );
80 my $finder_coderef = _caching_finder( \%cache );
81 $self->{_doc}->find( $finder_coderef );
82 $self->{_elements_of} = \%cache;
85 # find() must return false-but-defined on fail
86 return $self->{_elements_of}->{$wanted} || q{};
89 #-----------------------------------------------------------------------------
92 my ($self, $wanted, @more_args) = @_;
94 # This method can only find elements by their class names. For
95 # other types of searches, delegate to the PPI::Document
96 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
97 return $self->{_doc}->find_first($wanted, @more_args);
100 my $result = $self->find($wanted);
101 return $result ? $result->[0] : $result;
104 #-----------------------------------------------------------------------------
107 my ($self, $wanted, @more_args) = @_;
109 # This method can only find elements by their class names. For
110 # other types of searches, delegate to the PPI::Document
111 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
112 return $self->{_doc}->find_any($wanted, @more_args);
115 my $result = $self->find($wanted);
116 return $result ? 1 : $result;
119 #-----------------------------------------------------------------------------
123 return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
126 #-----------------------------------------------------------------------------
128 sub highest_explicit_perl_version {
131 my $highest_explicit_perl_version =
132 $self->{_highest_explicit_perl_version};
134 if ( not exists $self->{_highest_explicit_perl_version} ) {
135 my $includes = $self->find( \&_is_a_version_statement );
138 $highest_explicit_perl_version =
139 max map { version->new( $_->version() ) } @{$includes};
142 $highest_explicit_perl_version = undef;
145 $self->{_highest_explicit_perl_version} =
146 $highest_explicit_perl_version;
149 return $highest_explicit_perl_version if $highest_explicit_perl_version;
153 sub _is_a_version_statement {
154 my (undef, $element) = @_;
156 return 0 if not $element->isa('PPI::Statement::Include');
157 return 1 if $element->version();
161 #-----------------------------------------------------------------------------
163 sub _caching_finder {
165 my $cache_ref = shift; # These vars will persist for the life
166 my %isa_cache = (); # of the code ref that this sub returns
169 # Gather up all the PPI elements and sort by @ISA. Note: if any
170 # instances used multiple inheritance, this implementation would
171 # lead to multiple copies of $element in the $elements_of lists.
172 # However, PPI::* doesn't do multiple inheritance, so we are safe
175 my (undef, $element) = @_;
176 my $classes = $isa_cache{ref $element};
178 $classes = [ ref $element ];
179 # Use a C-style loop because we append to the classes array inside
180 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
181 no strict 'refs'; ## no critic(ProhibitNoStrict)
182 push @{$classes}, @{"$classes->[$i]::ISA"};
183 $cache_ref->{$classes->[$i]} ||= [];
185 $isa_cache{$classes->[0]} = $classes;
188 for my $class ( @{$classes} ) {
189 push @{$cache_ref->{$class}}, $element;
192 return 0; # 0 tells find() to keep traversing, but not to store this $element
196 #-----------------------------------------------------------------------------
204 =for stopwords pre-caches
208 Perl::Critic::Document - Caching wrapper around a PPI::Document.
214 use Perl::Critic::Document;
215 my $doc = PPI::Document->new('Foo.pm');
216 $doc = Perl::Critic::Document->new($doc);
217 ## Then use the instance just like a PPI::Document
222 Perl::Critic does a lot of iterations over the PPI document tree via
223 the C<PPI::Document::find()> method. To save some time, this class
224 pre-caches a lot of the common C<find()> calls in a single traversal.
225 Then, on subsequent requests we return the cached data.
227 This is implemented as a facade, where method calls are handed to the
228 stored C<PPI::Document> instance.
233 This facade does not implement the overloaded operators from
234 L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
235 users of this facade must not rely on that syntactic sugar. So, for
236 example, instead of C<my $source = "$doc";> you should write C<my
237 $source = $doc->content();>
239 Perhaps there is a CPAN module out there which implements a facade
240 better than we do here?
247 =item C<< new($doc) >>
249 Create a new instance referencing a PPI::Document instance.
259 =item C<< new($doc) >>
261 Create a new instance referencing a PPI::Document instance.
264 =item C<< ppi_document() >>
266 Accessor for the wrapped PPI::Document instance. Note that altering this
267 instance in any way can cause unpredictable failures in Perl::Critic's
268 subsequent analysis because some caches may fall out of date.
271 =item C<< find($wanted) >>
273 =item C<< find_first($wanted) >>
275 =item C<< find_any($wanted) >>
277 If C<$wanted> is a simple PPI class name, then the cache is employed.
278 Otherwise we forward the call to the corresponding method of the
279 C<PPI::Document> instance.
282 =item C<< filename() >>
284 Returns the filename for the source code if applicable
285 (PPI::Document::File) or C<undef> otherwise (PPI::Document).
288 =item C<< isa( $classname ) >>
290 To be compatible with other modules that expect to get a PPI::Document, the
291 Perl::Critic::Document class masquerades as the PPI::Document class.
294 =item C<< highest_explicit_perl_version() >>
296 Returns a L<version> object for the highest Perl version requirement declared
297 in the document via a C<use> or C<require> statement. Returns nothing if
298 there is no version statement.
306 Chris Dolan <cdolan@cpan.org>
311 Copyright (c) 2006-2008 Chris Dolan. All rights reserved.
313 This program is free software; you can redistribute it and/or modify
314 it under the same terms as Perl itself. The full text of this license
315 can be found in the LICENSE file included with this module.
321 # cperl-indent-level: 4
323 # indent-tabs-mode: nil
324 # c-indentation-style: bsd
326 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :