Commit | Line | Data |
---|---|---|
5bf96118 CD |
1 | ####################################################################### |
2 | # $URL$ | |
3 | # $Date$ | |
4 | # $Author$ | |
5 | # $Revision$ | |
6 | ######################################################################## | |
7 | ||
8 | package Perl::Critic::Document; | |
9 | ||
10 | use warnings; | |
11 | use strict; | |
12 | use PPI::Document; | |
13 | ||
14 | our $VERSION = '0.18'; | |
15 | $VERSION = eval $VERSION; ## no critic | |
16 | ||
17 | #---------------------------------------------------------------------------- | |
18 | ||
19 | our $AUTOLOAD; | |
20 | sub 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 | ||
27 | sub new { | |
28 | my $class = shift; | |
29 | my $doc = shift; | |
30 | ||
31 | return bless { _doc => $doc }, $class; | |
32 | } | |
33 | ||
34 | sub 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 | ||
78 | 1; | |
79 | __END__ | |
80 | ||
81 | =head1 NAME | |
82 | ||
83 | Perl::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 | ||
95 | Perl::Critic does a lot of iterations over the PPI document tree via | |
96 | the C<PPI::Document::find()> method. To save some time, this class | |
97 | pre-caches a lot of the common C<find()> calls in a single traversal. | |
98 | Then, on subsequent requests we return the cached data. | |
99 | ||
100 | This is implemented as a facade, where method calls are handed to the | |
101 | stored C<PPI::Document> instance. | |
102 | ||
103 | =head1 CAVEATS | |
104 | ||
105 | This facade does not implement the overloaded operators from | |
106 | L<PPI::Document> (that is, the C<use overload ...> work). Therefore, | |
107 | users of this facade must not rely on that syntactic sugar. So, for | |
108 | example, instead of C<my $source = "$doc";> you should write C<my | |
109 | $source = $doc->content();> | |
110 | ||
111 | Perhaps there is a CPAN module out there which implements a facade | |
112 | better than we do here? | |
113 | ||
114 | =head1 METHODS | |
115 | ||
116 | =over | |
117 | ||
118 | =item $self->find($wanted) | |
119 | ||
120 | If C<wanted> is a simple PPI class name, then the cache is employed. | |
121 | Otherwise we forward the call to the C<find()> method of the | |
122 | C<PPI::Document> instance. | |
123 | ||
124 | =back | |
125 | ||
126 | =head1 AUTHOR | |
127 | ||
128 | Chris Dolan <cdolan@cpan.org> | |
129 | ||
130 | =head1 COPYRIGHT | |
131 | ||
132 | Copyright (c) 2006 Chris Dolan. All rights reserved. | |
133 | ||
134 | This program is free software; you can redistribute it and/or modify | |
135 | it under the same terms as Perl itself. The full text of this license | |
136 | can be found in the LICENSE file included with this module. | |
137 | ||
138 | =cut |