git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/Document.pm

   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) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 package Perl::Critic::Document;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use List::Util qw< max >;
  15 use PPI::Document;
  16 use Scalar::Util qw< weaken >;
  17 use version;
  18
  19 #-----------------------------------------------------------------------------
  20
  21 our $VERSION = '1.088';
  22
  23 #-----------------------------------------------------------------------------
  24
  25 our $AUTOLOAD;
  26 sub 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(@_);
  31 }
  32
  33 #-----------------------------------------------------------------------------
  34
  35 sub new {
  36     my ($class, $doc) = @_;
  37     return bless { _doc => $doc }, $class;
  38 }
  39
  40 #-----------------------------------------------------------------------------
  41
  42 sub ppi_document {
  43     my ($self) = @_;
  44     return $self->{_doc};
  45 }
  46
  47 #-----------------------------------------------------------------------------
  48
  49 sub isa {
  50     my ($self, @args) = @_;
  51     return $self->SUPER::isa(@args)
  52         || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
  53 }
  54
  55 #-----------------------------------------------------------------------------
  56
  57 sub find {
  58     my ($self, $wanted, @more_args) = @_;
  59
  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);
  64     }
  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.
  70     if ( !$self->{_elements_of} ) {
  71
  72         my %cache = ( 'PPI::Document' => [ $self ] );
  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
  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
  89 #-----------------------------------------------------------------------------
  90
  91 sub find_first {
  92     my ($self, $wanted, @more_args) = @_;
  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 ) {
  97         return $self->{_doc}->find_first($wanted, @more_args);
  98     }
  99
 100     my $result = $self->find($wanted);
 101     return $result ? $result->[0] : $result;
 102 }
 103
 104 #-----------------------------------------------------------------------------
 105
 106 sub find_any {
 107     my ($self, $wanted, @more_args) = @_;
 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 ) {
 112         return $self->{_doc}->find_any($wanted, @more_args);
 113     }
 114
 115     my $result = $self->find($wanted);
 116     return $result ? 1 : $result;
 117 }
 118
 119 #-----------------------------------------------------------------------------
 120
 121 sub filename {
 122     my ($self) = @_;
 123     return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
 124 }
 125
 126 #-----------------------------------------------------------------------------
 127
 128 sub 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) {
 138             $highest_explicit_perl_version =
 139                 max map { version->new( $_->version() ) } @{$includes};
 140         }
 141         else {
 142             $highest_explicit_perl_version = undef;
 143         }
 144
 145         $self->{_highest_explicit_perl_version} =
 146             $highest_explicit_perl_version;
 147     }
 148
 149     return $highest_explicit_perl_version if $highest_explicit_perl_version;
 150     return;
 151 }
 152
 153 sub _is_a_version_statement {
 154     my (undef, $element) = @_;
 155
 156     return 0 if not $element->isa('PPI::Statement::Include');
 157     return 1 if $element->version();
 158     return 0;
 159 }
 160
 161 #-----------------------------------------------------------------------------
 162
 163 sub _caching_finder {
 164
 165     my $cache_ref = shift;  # These vars will persist for the life
 166     my %isa_cache = ();     # of the code ref that this sub returns
 167
 168
 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
 173
 174     return sub {
 175         my (undef, $element) = @_;
 176         my $classes = $isa_cache{ref $element};
 177         if ( !$classes ) {
 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]} ||= [];
 184             }
 185             $isa_cache{$classes->[0]} = $classes;
 186         }
 187
 188         for my $class ( @{$classes} ) {
 189             push @{$cache_ref->{$class}}, $element;
 190         }
 191
 192         return 0; # 0 tells find() to keep traversing, but not to store this $element
 193     };
 194 }
 195
 196 #-----------------------------------------------------------------------------
 197
 198 1;
 199
 200 __END__
 201
 202 =pod
 203
 204 =for stopwords pre-caches
 205
 206 =head1 NAME
 207
 208 Perl::Critic::Document - Caching wrapper around a PPI::Document.
 209
 210
 211 =head1 SYNOPSIS
 212
 213     use 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
 218
 219
 220 =head1 DESCRIPTION
 221
 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.
 226
 227 This is implemented as a facade, where method calls are handed to the
 228 stored C<PPI::Document> instance.
 229
 230
 231 =head1 CAVEATS
 232
 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();>
 238
 239 Perhaps there is a CPAN module out there which implements a facade
 240 better than we do here?
 241
 242
 243 =head1 CONSTRUCTOR
 244
 245 =over
 246
 247 =item C<< new($doc) >>
 248
 249 Create a new instance referencing a PPI::Document instance.
 250
 251
 252 =back
 253
 254
 255 =head1 METHODS
 256
 257 =over
 258
 259 =item C<< new($doc) >>
 260
 261 Create a new instance referencing a PPI::Document instance.
 262
 263
 264 =item C<< ppi_document() >>
 265
 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.
 269
 270
 271 =item C<< find($wanted) >>
 272
 273 =item C<< find_first($wanted) >>
 274
 275 =item C<< find_any($wanted) >>
 276
 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.
 280
 281
 282 =item C<< filename() >>
 283
 284 Returns the filename for the source code if applicable
 285 (PPI::Document::File) or C<undef> otherwise (PPI::Document).
 286
 287
 288 =item C<< isa( $classname ) >>
 289
 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.
 292
 293
 294 =item C<< highest_explicit_perl_version() >>
 295
 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.
 299
 300
 301 =back
 302
 303
 304 =head1 AUTHOR
 305
 306 Chris Dolan <cdolan@cpan.org>
 307
 308
 309 =head1 COPYRIGHT
 310
 311 Copyright (c) 2006-2008 Chris Dolan.  All rights reserved.
 312
 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.
 316
 317 =cut
 318
 319 # Local Variables:
 320 #   mode: cperl
 321 #   cperl-indent-level: 4
 322 #   fill-column: 78
 323 #   indent-tabs-mode: nil
 324 #   c-indentation-style: bsd
 325 # End:
 326 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :