Login
Just comment formatting changes.
[gknop/Perl-Critic.git] / lib / Perl / Critic / Document.pm
CommitLineData
6036a254 1##############################################################################
a73f4a71
JRT
2# $URL$
3# $Date$
4# $Author$
5# $Revision$
6036a254 6##############################################################################
5bf96118
CD
7
8package Perl::Critic::Document;
9
df6dee2b 10use 5.006001;
5bf96118 11use strict;
58a9e587 12use warnings;
267b39b4
ES
13
14use List::Util qw< max >;
5bf96118 15use PPI::Document;
267b39b4
ES
16use Scalar::Util qw< weaken >;
17use version;
5bf96118 18
6036a254 19#-----------------------------------------------------------------------------
58a9e587 20
173667ce 21our $VERSION = '1.093_01';
5bf96118 22
6036a254 23#-----------------------------------------------------------------------------
5bf96118
CD
24
25our $AUTOLOAD;
6e7d6c9f
CD
26sub AUTOLOAD { ## no critic(ProhibitAutoloading,ArgUnpacking)
27 my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
28 return if $function_name eq 'DESTROY';
29 my $self = shift;
30 return $self->{_doc}->$function_name(@_);
5bf96118
CD
31}
32
6036a254 33#-----------------------------------------------------------------------------
5bf96118 34
58a9e587
JRT
35sub new {
36 my ($class, $doc) = @_;
5bf96118
CD
37 return bless { _doc => $doc }, $class;
38}
39
6036a254 40#-----------------------------------------------------------------------------
58a9e587 41
2b6293b2
CD
42sub ppi_document {
43 my ($self) = @_;
44 return $self->{_doc};
45}
46
47#-----------------------------------------------------------------------------
48
47e1ff34 49sub isa {
6e7d6c9f
CD
50 my ($self, @args) = @_;
51 return $self->SUPER::isa(@args)
52 || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
47e1ff34
CD
53}
54
6036a254 55#-----------------------------------------------------------------------------
47e1ff34 56
5bf96118 57sub find {
6e7d6c9f 58 my ($self, $wanted, @more_args) = @_;
5bf96118 59
58a9e587
JRT
60 # This method can only find elements by their class names. For
61 # other types of searches, delegate to the PPI::Document
5bf96118 62 if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f 63 return $self->{_doc}->find($wanted, @more_args);
5bf96118 64 }
58a9e587
JRT
65
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.
5bf96118 70 if ( !$self->{_elements_of} ) {
389109ec 71
58a9e587 72 my %cache = ( 'PPI::Document' => [ $self ] );
389109ec
JRT
73
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] );
79
58a9e587
JRT
80 my $finder_coderef = _caching_finder( \%cache );
81 $self->{_doc}->find( $finder_coderef );
82 $self->{_elements_of} = \%cache;
83 }
84
85 # find() must return false-but-defined on fail
86 return $self->{_elements_of}->{$wanted} || q{};
87}
88
6036a254 89#-----------------------------------------------------------------------------
58a9e587 90
fb21e21e 91sub find_first {
6e7d6c9f 92 my ($self, $wanted, @more_args) = @_;
fb21e21e
CD
93
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 ) {
6e7d6c9f 97 return $self->{_doc}->find_first($wanted, @more_args);
fb21e21e
CD
98 }
99
100 my $result = $self->find($wanted);
101 return $result ? $result->[0] : $result;
102}
103
6036a254 104#-----------------------------------------------------------------------------
fb21e21e 105
f5eeac3b 106sub find_any {
6e7d6c9f 107 my ($self, $wanted, @more_args) = @_;
f5eeac3b
CD
108
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 ) {
6e7d6c9f 112 return $self->{_doc}->find_any($wanted, @more_args);
f5eeac3b
CD
113 }
114
115 my $result = $self->find($wanted);
116 return $result ? 1 : $result;
117}
118
6036a254 119#-----------------------------------------------------------------------------
f5eeac3b 120
60108aef
CD
121sub filename {
122 my ($self) = @_;
123 return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
124}
125
6036a254 126#-----------------------------------------------------------------------------
60108aef 127
267b39b4
ES
128sub highest_explicit_perl_version {
129 my ($self) = @_;
130
131 my $highest_explicit_perl_version =
132 $self->{_highest_explicit_perl_version};
133
134 if ( not exists $self->{_highest_explicit_perl_version} ) {
135 my $includes = $self->find( \&_is_a_version_statement );
136
137 if ($includes) {
1ebef5a9
ES
138 # Note: this will complain about underscores, e.g. "use
139 # 5.008_000". However, nothing important should be depending upon
140 # alpha perl versions and marking non-alpha versions as alpha is
141 # bad in and of itself. Note that this contradicts an example in
142 # perlfunc about "use".
267b39b4
ES
143 $highest_explicit_perl_version =
144 max map { version->new( $_->version() ) } @{$includes};
145 }
146 else {
147 $highest_explicit_perl_version = undef;
148 }
149
150 $self->{_highest_explicit_perl_version} =
151 $highest_explicit_perl_version;
152 }
153
154 return $highest_explicit_perl_version if $highest_explicit_perl_version;
155 return;
156}
157
158sub _is_a_version_statement {
159 my (undef, $element) = @_;
160
161 return 0 if not $element->isa('PPI::Statement::Include');
162 return 1 if $element->version();
163 return 0;
164}
165
166#-----------------------------------------------------------------------------
167
58a9e587
JRT
168sub _caching_finder {
169
170 my $cache_ref = shift; # These vars will persist for the life
171 my %isa_cache = (); # of the code ref that this sub returns
172
173
174 # Gather up all the PPI elements and sort by @ISA. Note: if any
175 # instances used multiple inheritance, this implementation would
176 # lead to multiple copies of $element in the $elements_of lists.
177 # However, PPI::* doesn't do multiple inheritance, so we are safe
178
179 return sub {
6e7d6c9f 180 my (undef, $element) = @_;
58a9e587
JRT
181 my $classes = $isa_cache{ref $element};
182 if ( !$classes ) {
183 $classes = [ ref $element ];
184 # Use a C-style loop because we append to the classes array inside
185 for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
186 no strict 'refs'; ## no critic(ProhibitNoStrict)
187 push @{$classes}, @{"$classes->[$i]::ISA"};
188 $cache_ref->{$classes->[$i]} ||= [];
5bf96118 189 }
58a9e587
JRT
190 $isa_cache{$classes->[0]} = $classes;
191 }
5bf96118 192
58a9e587
JRT
193 for my $class ( @{$classes} ) {
194 push @{$cache_ref->{$class}}, $element;
195 }
5bf96118 196
58a9e587
JRT
197 return 0; # 0 tells find() to keep traversing, but not to store this $element
198 };
5bf96118
CD
199}
200
6036a254 201#-----------------------------------------------------------------------------
58a9e587 202
5bf96118 2031;
58a9e587 204
5bf96118
CD
205__END__
206
a73f4a71
JRT
207=pod
208
209=for stopwords pre-caches
210
5bf96118
CD
211=head1 NAME
212
c728943a 213Perl::Critic::Document - Caching wrapper around a PPI::Document.
5bf96118 214
267b39b4 215
5bf96118
CD
216=head1 SYNOPSIS
217
218 use PPI::Document;
219 use Perl::Critic::Document;
220 my $doc = PPI::Document->new('Foo.pm');
221 $doc = Perl::Critic::Document->new($doc);
222 ## Then use the instance just like a PPI::Document
223
267b39b4 224
5bf96118
CD
225=head1 DESCRIPTION
226
227Perl::Critic does a lot of iterations over the PPI document tree via
228the C<PPI::Document::find()> method. To save some time, this class
229pre-caches a lot of the common C<find()> calls in a single traversal.
230Then, on subsequent requests we return the cached data.
231
232This is implemented as a facade, where method calls are handed to the
233stored C<PPI::Document> instance.
234
267b39b4 235
5bf96118
CD
236=head1 CAVEATS
237
238This facade does not implement the overloaded operators from
11f53956
ES
239L<PPI::Document|PPI::Document> (that is, the C<use overload ...>
240work). Therefore, users of this facade must not rely on that syntactic
241sugar. So, for example, instead of C<my $source = "$doc";> you should
242write C<my $source = $doc->content();>
5bf96118
CD
243
244Perhaps there is a CPAN module out there which implements a facade
245better than we do here?
246
267b39b4
ES
247
248=head1 CONSTRUCTOR
249
250=over
251
252=item C<< new($doc) >>
253
254Create a new instance referencing a PPI::Document instance.
255
256
257=back
258
259
5bf96118
CD
260=head1 METHODS
261
262=over
263
267b39b4 264=item C<< new($doc) >>
7076e807
CD
265
266Create a new instance referencing a PPI::Document instance.
267
267b39b4
ES
268
269=item C<< ppi_document() >>
2b6293b2 270
11f53956
ES
271Accessor for the wrapped PPI::Document instance. Note that altering
272this instance in any way can cause unpredictable failures in
273Perl::Critic's subsequent analysis because some caches may fall out of
274date.
2b6293b2 275
5bf96118 276
267b39b4
ES
277=item C<< find($wanted) >>
278
279=item C<< find_first($wanted) >>
fb21e21e 280
267b39b4 281=item C<< find_any($wanted) >>
f5eeac3b 282
fb21e21e 283If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b
CD
284Otherwise we forward the call to the corresponding method of the
285C<PPI::Document> instance.
5bf96118 286
267b39b4
ES
287
288=item C<< filename() >>
e7f2d995
CD
289
290Returns the filename for the source code if applicable
291(PPI::Document::File) or C<undef> otherwise (PPI::Document).
292
267b39b4
ES
293
294=item C<< isa( $classname ) >>
242f7b08 295
11f53956
ES
296To be compatible with other modules that expect to get a
297PPI::Document, the Perl::Critic::Document class masquerades as the
298PPI::Document class.
242f7b08 299
267b39b4
ES
300
301=item C<< highest_explicit_perl_version() >>
302
11f53956
ES
303Returns a L<version|version> object for the highest Perl version
304requirement declared in the document via a C<use> or C<require>
305statement. Returns nothing if there is no version statement.
267b39b4
ES
306
307
5bf96118
CD
308=back
309
267b39b4 310
5bf96118
CD
311=head1 AUTHOR
312
313Chris Dolan <cdolan@cpan.org>
314
267b39b4 315
5bf96118
CD
316=head1 COPYRIGHT
317
20dfddeb 318Copyright (c) 2006-2008 Chris Dolan. All rights reserved.
5bf96118
CD
319
320This program is free software; you can redistribute it and/or modify
321it under the same terms as Perl itself. The full text of this license
322can be found in the LICENSE file included with this module.
323
324=cut
737d3b65
CD
325
326# Local Variables:
327# mode: cperl
328# cperl-indent-level: 4
329# fill-column: 78
330# indent-tabs-mode: nil
331# c-indentation-style: bsd
332# End:
96fed375 333# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :