[gknop/Perl-Critic.git] / lib / Perl / Critic / Document.pm

##############################################################################
#      $URL$
#     $Date$
#   $Author$
# $Revision$
##############################################################################

package Perl::Critic::Document;

use 5.006001;
use strict;
use warnings;

use List::Util qw< max >;
use PPI::Document;
use Scalar::Util qw< weaken >;
use version;

#-----------------------------------------------------------------------------

our $VERSION = '1.093_01';

#-----------------------------------------------------------------------------

our $AUTOLOAD;
sub AUTOLOAD {  ## no critic (ProhibitAutoloading,ArgUnpacking)
    my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms;
    return if $function_name eq 'DESTROY';
    my $self = shift;
    return $self->{_doc}->$function_name(@_);
}

#-----------------------------------------------------------------------------

sub new {
    my ($class, $doc) = @_;
    my $self = bless {}, $class;
    $self->{_disabled_lines} = _unfix_shebang($doc);
    $self->{_doc} = $doc;
    return $self;
}

#-----------------------------------------------------------------------------

sub ppi_document {
    my ($self) = @_;
    return $self->{_doc};
}

#-----------------------------------------------------------------------------

sub isa {
    my ($self, @args) = @_;
    return $self->SUPER::isa(@args)
        || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
}

#-----------------------------------------------------------------------------

sub find {
    my ($self, $wanted, @more_args) = @_;

    # This method can only find elements by their class names.  For
    # other types of searches, delegate to the PPI::Document
    if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
        return $self->{_doc}->find($wanted, @more_args);
    }

    # Build the class cache if it doesn't exist.  This happens at most
    # once per Perl::Critic::Document instance.  %elements of will be
    # populated as a side-effect of calling the $finder_sub coderef
    # that is produced by the caching_finder() closure.
    if ( !$self->{_elements_of} ) {

        my %cache = ( 'PPI::Document' => [ $self ] );

        # The cache refers to $self, and $self refers to the cache.  This
        # creates a circular reference that leaks memory (i.e.  $self is not
        # destroyed until execution is complete).  By weakening the reference,
        # we allow perl to collect the garbage properly.
        weaken( $cache{'PPI::Document'}->[0] );

        my $finder_coderef = _caching_finder( \%cache );
        $self->{_doc}->find( $finder_coderef );
        $self->{_elements_of} = \%cache;
    }

    # find() must return false-but-defined on fail
    return $self->{_elements_of}->{$wanted} || q{};
}

#-----------------------------------------------------------------------------

sub find_first {
    my ($self, $wanted, @more_args) = @_;

    # This method can only find elements by their class names.  For
    # other types of searches, delegate to the PPI::Document
    if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
        return $self->{_doc}->find_first($wanted, @more_args);
    }

    my $result = $self->find($wanted);
    return $result ? $result->[0] : $result;
}

#-----------------------------------------------------------------------------

sub find_any {
    my ($self, $wanted, @more_args) = @_;

    # This method can only find elements by their class names.  For
    # other types of searches, delegate to the PPI::Document
    if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) {
        return $self->{_doc}->find_any($wanted, @more_args);
    }

    my $result = $self->find($wanted);
    return $result ? 1 : $result;
}

#-----------------------------------------------------------------------------

sub filename {
    my ($self) = @_;
    return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
}

#-----------------------------------------------------------------------------

sub highest_explicit_perl_version {
    my ($self) = @_;

    my $highest_explicit_perl_version =
        $self->{_highest_explicit_perl_version};

    if ( not exists $self->{_highest_explicit_perl_version} ) {
        my $includes = $self->find( \&_is_a_version_statement );

        if ($includes) {
            # Note: this will complain about underscores, e.g. "use
            # 5.008_000".  However, nothing important should be depending upon
            # alpha perl versions and marking non-alpha versions as alpha is
            # bad in and of itself.  Note that this contradicts an example in
            # perlfunc about "use".
            $highest_explicit_perl_version =
                max map { version->new( $_->version() ) } @{$includes};
        }
        else {
            $highest_explicit_perl_version = undef;
        }

        $self->{_highest_explicit_perl_version} =
            $highest_explicit_perl_version;
    }

    return $highest_explicit_perl_version if $highest_explicit_perl_version;
    return;
}

#-----------------------------------------------------------------------------

sub mark_disabled_lines {
    my ($self, @site_policies) = @_;
    my %disabled_lines = _find_disabled_lines($self->{_doc}, @site_policies);

    # Ick.  Need to merge the disabled lines hash with the shebang lines
    # that we alread disabled during the _unfix_shebang() process.  Need
    # to find a better way to express this.

    $self->{_disabled_lines} = { %{$self->{_disabled_lines}}, %disabled_lines };
    return $self;
}

#-----------------------------------------------------------------------------

sub is_line_disabled {
    my ($self, $line, $policy_name) = @_;
    return 0 if not exists $self->{_disabled_lines}->{$line};
    return 1 if $self->{_disabled_lines}->{$line}->{$policy_name};
    return 1 if $self->{_disabled_lines}->{$line}->{ALL};
    return 0;
}

#-----------------------------------------------------------------------------

sub _is_a_version_statement {
    my (undef, $element) = @_;

    return 0 if not $element->isa('PPI::Statement::Include');
    return 1 if $element->version();
    return 0;
}

#-----------------------------------------------------------------------------

sub _caching_finder {

    my $cache_ref = shift;  # These vars will persist for the life
    my %isa_cache = ();     # of the code ref that this sub returns


    # Gather up all the PPI elements and sort by @ISA.  Note: if any
    # instances used multiple inheritance, this implementation would
    # lead to multiple copies of $element in the $elements_of lists.
    # However, PPI::* doesn't do multiple inheritance, so we are safe

    return sub {
        my (undef, $element) = @_;
        my $classes = $isa_cache{ref $element};
        if ( !$classes ) {
            $classes = [ ref $element ];
            # Use a C-style loop because we append to the classes array inside
            for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
                no strict 'refs';                       ## no critic(ProhibitNoStrict)
                push @{$classes}, @{"$classes->[$i]::ISA"};
                $cache_ref->{$classes->[$i]} ||= [];
            }
            $isa_cache{$classes->[0]} = $classes;
        }

        for my $class ( @{$classes} ) {
            push @{$cache_ref->{$class}}, $element;
        }

        return 0; # 0 tells find() to keep traversing, but not to store this $element
    };
}

#-----------------------------------------------------------------------------

sub _find_disabled_lines {

    my ($doc, @site_policies)= @_;

    my $nodes_ref  = $doc->find('PPI::Token::Comment') || return;
    my %disabled_lines;

    _disable_shebang_line($nodes_ref, \%disabled_lines, \@site_policies);
    _disable_other_lines($nodes_ref, \%disabled_lines, \@site_policies);
    return %disabled_lines;
}

#-----------------------------------------------------------------------------

sub _disable_shebang_line {
    my ($nodes_ref, $disabled_lines, $site_policies) = @_;

    my $shebang_no_critic  = qr{\A [#]! .*? [#][#] \s* no  \s+ critic}xms;

    # Special case for the very beginning of the file: allow "##no critic" after the shebang
    if (0 < @{$nodes_ref}) {
        my $loc = $nodes_ref->[0]->location;
        if (1 == $loc->[0] && 1 == $loc->[1] && $nodes_ref->[0] =~ $shebang_no_critic) {
            my $pragma = shift @{$nodes_ref};
            for my $policy (_parse_nocritic_import($pragma, $site_policies)) {
                $disabled_lines->{ 1 }->{$policy} = 1;
            }
        }
    }
    return;
}

#-----------------------------------------------------------------------------

sub _disable_other_lines {
    my ($nodes_ref, $disabled_lines, $site_policies) = @_;

    my $no_critic  = qr{\A \s* [#][#] \s* no  \s+ critic}xms;
    my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}xms;

  PRAGMA:
    for my $pragma ( grep { $_ =~ $no_critic } @{$nodes_ref} ) {

        # Parse out the list of Policy names after the
        # 'no critic' pragma.  I'm thinking of this just
        # like a an C<import> argument for real pragmas.
        my @no_policies = _parse_nocritic_import($pragma, $site_policies);

        # Grab surrounding nodes to determine the context.
        # This determines whether the pragma applies to
        # the current line or the block that follows.
        my $parent = $pragma->parent();
        my $grandparent = $parent ? $parent->parent() : undef;
        my $sib = $pragma->sprevious_sibling();


        # Handle single-line usage on simple statements
        if ( $sib && $sib->location->[0] == $pragma->location->[0] ) {
            my $line = $pragma->location->[0];
            for my $policy ( @no_policies ) {
                $disabled_lines->{ $line }->{$policy} = 1;
            }
            next PRAGMA;
        }


        # Handle single-line usage on compound statements
        if ( ref $parent eq 'PPI::Structure::Block' ) {
            if ( ref $grandparent eq 'PPI::Statement::Compound'
                 || ref $grandparent eq 'PPI::Statement::Sub' ) {
                if ( $parent->location->[0] == $pragma->location->[0] ) {
                    my $line = $grandparent->location->[0];
                    for my $policy ( @no_policies ) {
                        $disabled_lines->{ $line }->{$policy} = 1;
                    }
                    next PRAGMA;
                }
            }
        }


        # Handle multi-line usage.  This is either a "no critic" ..
        # "use critic" region or a block where "no critic" persists
        # until the end of the scope.  The start is the always the "no
        # critic" which we already found.  So now we have to search
        # for the end.

        my $start = $pragma;
        my $end   = $pragma;

      SIB:
        while ( my $esib = $end->next_sibling() ) {
            $end = $esib; # keep track of last sibling encountered in this scope
            last SIB
                if $esib->isa('PPI::Token::Comment') && $esib =~ $use_critic;
        }

        # We either found an end or hit the end of the scope.
        # Flag all intervening lines
        for my $line ( $start->location->[0] .. $end->location->[0] ) {
            for my $policy ( @no_policies ) {
                $disabled_lines->{ $line }->{$policy} = 1;
            }
        }
    }

    return;
}

#-----------------------------------------------------------------------------

sub _parse_nocritic_import {

    my ($pragma, $site_policies) = @_;

    my $module    = qr{ [\w:]+ }xms;
    my $delim     = qr{ \s* [,\s] \s* }xms;
    my $qw        = qr{ (?: qw )? }xms;
    my $qualifier = qr{ $qw [(]? \s* ( $module (?: $delim $module)* ) \s* [)]? }xms;
    my $no_critic = qr{ \#\# \s* no \s+ critic \s* $qualifier }xms;  ##no critic(EscapedMetacharacters)

    if ( my ($module_list) = $pragma =~ $no_critic ) {
        my @modules = split $delim, $module_list;

        # Compose the specified modules into a regex alternation.  Wrap each
        # in a no-capturing group to permit "|" in the modules specification
        # (backward compatibility)
        my $re = join q{|}, map {"(?:$_)"} @modules;
        return grep {m/$re/ixms} @{$site_policies};
    }

    # Default to disabling ALL policies.
    return qw(ALL);
}

#-----------------------------------------------------------------------------

sub _unfix_shebang {

    # When you install a script using ExtUtils::MakeMaker or Module::Build, it
    # inserts some magical code into the top of the file (just after the
    # shebang).  This code allows people to call your script using a shell,
    # like `sh my_script`.  Unfortunately, this code causes several Policy
    # violations, so we just disable it as if a "## no critic" comment had
    # been attached.

    my $doc         = shift;
    my $first_stmnt = $doc->schild(0) || return {};

    # Different versions of MakeMaker and Build use slightly different shebang
    # fixing strings.  This matches most of the ones I've found in my own Perl
    # distribution, but it may not be bullet-proof.

    my $fixin_rx = qr{^eval 'exec .* \$0 \${1\+"\$@"}'\s*[\r\n]\s*if.+;}ms; ## no critic (RequireExtendedFormatting)
    if ( $first_stmnt =~ $fixin_rx ) {
        my $line = $first_stmnt->location()->[0];
        return { $line => {ALL => 1}, $line + 1 => {ALL => 1} };
    }

    #No magic shebang was found!
    return {};
}

#-----------------------------------------------------------------------------

1;

__END__

=pod

=for stopwords pre-caches

=head1 NAME

Perl::Critic::Document - Caching wrapper around a PPI::Document.


=head1 SYNOPSIS

    use PPI::Document;
    use Perl::Critic::Document;
    my $doc = PPI::Document->new('Foo.pm');
    $doc = Perl::Critic::Document->new($doc);
    ## Then use the instance just like a PPI::Document


=head1 DESCRIPTION

Perl::Critic does a lot of iterations over the PPI document tree via
the C<PPI::Document::find()> method.  To save some time, this class
pre-caches a lot of the common C<find()> calls in a single traversal.
Then, on subsequent requests we return the cached data.

This is implemented as a facade, where method calls are handed to the
stored C<PPI::Document> instance.


=head1 CAVEATS

This facade does not implement the overloaded operators from
L<PPI::Document|PPI::Document> (that is, the C<use overload ...>
work). Therefore, users of this facade must not rely on that syntactic
sugar.  So, for example, instead of C<my $source = "$doc";> you should
write C<my $source = $doc->content();>

Perhaps there is a CPAN module out there which implements a facade
better than we do here?


=head1 CONSTRUCTOR

=over

=item C<< new($doc) >>

Create a new instance referencing a PPI::Document instance.


=back


=head1 METHODS

=over

=item C<< new($doc) >>

Create a new instance referencing a PPI::Document instance.


=item C<< ppi_document() >>

Accessor for the wrapped PPI::Document instance.  Note that altering
this instance in any way can cause unpredictable failures in
Perl::Critic's subsequent analysis because some caches may fall out of
date.


=item C<< find($wanted) >>

=item C<< find_first($wanted) >>

=item C<< find_any($wanted) >>

If C<$wanted> is a simple PPI class name, then the cache is employed.
Otherwise we forward the call to the corresponding method of the
C<PPI::Document> instance.


=item C<< filename() >>

Returns the filename for the source code if applicable
(PPI::Document::File) or C<undef> otherwise (PPI::Document).


=item C<< isa( $classname ) >>

To be compatible with other modules that expect to get a
PPI::Document, the Perl::Critic::Document class masquerades as the
PPI::Document class.


=item C<< highest_explicit_perl_version() >>

Returns a L<version|version> object for the highest Perl version
requirement declared in the document via a C<use> or C<require>
statement.  Returns nothing if there is no version statement.


=item C<< mark_disabled_lines( @policy_names ) >>

Scans the document for C<"## no critic"> pseudo-pragmas and builds
an internal table of which of the listed C<@policy_names> have
been disabled at each line.  Returns C<$self>.


=item C<< line_is_disabled($line, $policy_name) >>

Returns true if the given C<$policy_name> has been disabled for
at C<$line> in this document.  Otherwise, returns false.


=back


=head1 AUTHOR

Chris Dolan <cdolan@cpan.org>


=head1 COPYRIGHT

Copyright (c) 2006-2008 Chris Dolan.  All rights reserved.

This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  The full text of this license
can be found in the LICENSE file included with this module.

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
Commit	Line	Data
6036a254	1	##############################################################################
a73f4a71 JRT	2	# $URL$
	3	# $Date$
	4	# $Author$
	5	# $Revision$
6036a254	6	##############################################################################
5bf96118 CD	7
	8	package Perl::Critic::Document;
	9
df6dee2b	10	use 5.006001;
5bf96118	11	use strict;
58a9e587	12	use warnings;
267b39b4 ES	13
267b39b4 ES	14	use List::Util qw< max >;
5bf96118	15	use PPI::Document;
267b39b4 ES	16	use Scalar::Util qw< weaken >;
267b39b4 ES	17	use version;
5bf96118	18
6036a254	19	#-----------------------------------------------------------------------------
58a9e587	20
173667ce	21	our $VERSION = '1.093_01';
5bf96118	22
6036a254	23	#-----------------------------------------------------------------------------
5bf96118 CD	24
5bf96118 CD	25	our $AUTOLOAD;
937b8de0	26	sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking)
6e7d6c9f CD	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	}
5bf96118 CD	32
6036a254	33	#-----------------------------------------------------------------------------
5bf96118	34
58a9e587 JRT	35	sub new {
58a9e587 JRT	36	my ($class, $doc) = @_;
937b8de0 JRT	37	my $self = bless {}, $class;
	38	$self->{_disabled_lines} = _unfix_shebang($doc);
	39	$self->{_doc} = $doc;
	40	return $self;
5bf96118 CD	41	}
5bf96118 CD	42
6036a254	43	#-----------------------------------------------------------------------------
58a9e587	44
2b6293b2 CD	45	sub ppi_document {
	46	my ($self) = @_;
	47	return $self->{_doc};
	48	}
	49
	50	#-----------------------------------------------------------------------------
	51
47e1ff34	52	sub isa {
6e7d6c9f CD	53	my ($self, @args) = @_;
	54	return $self->SUPER::isa(@args)
	55	\|\| ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) );
47e1ff34 CD	56	}
47e1ff34 CD	57
6036a254	58	#-----------------------------------------------------------------------------
47e1ff34	59
5bf96118	60	sub find {
6e7d6c9f	61	my ($self, $wanted, @more_args) = @_;
5bf96118	62
58a9e587 JRT	63	# This method can only find elements by their class names. For
58a9e587 JRT	64	# other types of searches, delegate to the PPI::Document
5bf96118	65	if ( ( ref $wanted ) \|\| !$wanted \|\| $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f	66	return $self->{_doc}->find($wanted, @more_args);
5bf96118	67	}
58a9e587 JRT	68
	69	# Build the class cache if it doesn't exist. This happens at most
	70	# once per Perl::Critic::Document instance. %elements of will be
	71	# populated as a side-effect of calling the $finder_sub coderef
	72	# that is produced by the caching_finder() closure.
5bf96118	73	if ( !$self->{_elements_of} ) {
389109ec	74
58a9e587	75	my %cache = ( 'PPI::Document' => [ $self ] );
389109ec JRT	76
	77	# The cache refers to $self, and $self refers to the cache. This
	78	# creates a circular reference that leaks memory (i.e. $self is not
	79	# destroyed until execution is complete). By weakening the reference,
	80	# we allow perl to collect the garbage properly.
	81	weaken( $cache{'PPI::Document'}->[0] );
	82
58a9e587 JRT	83	my $finder_coderef = _caching_finder( \%cache );
	84	$self->{_doc}->find( $finder_coderef );
	85	$self->{_elements_of} = \%cache;
	86	}
	87
	88	# find() must return false-but-defined on fail
	89	return $self->{_elements_of}->{$wanted} \|\| q{};
	90	}
	91
6036a254	92	#-----------------------------------------------------------------------------
58a9e587	93
fb21e21e	94	sub find_first {
6e7d6c9f	95	my ($self, $wanted, @more_args) = @_;
fb21e21e CD	96
	97	# This method can only find elements by their class names. For
	98	# other types of searches, delegate to the PPI::Document
	99	if ( ( ref $wanted ) \|\| !$wanted \|\| $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f	100	return $self->{_doc}->find_first($wanted, @more_args);
fb21e21e CD	101	}
	102
	103	my $result = $self->find($wanted);
	104	return $result ? $result->[0] : $result;
	105	}
	106
6036a254	107	#-----------------------------------------------------------------------------
fb21e21e	108
f5eeac3b	109	sub find_any {
6e7d6c9f	110	my ($self, $wanted, @more_args) = @_;
f5eeac3b CD	111
	112	# This method can only find elements by their class names. For
	113	# other types of searches, delegate to the PPI::Document
	114	if ( ( ref $wanted ) \|\| !$wanted \|\| $wanted !~ m/ \A PPI:: /xms ) {
6e7d6c9f	115	return $self->{_doc}->find_any($wanted, @more_args);
f5eeac3b CD	116	}
	117
	118	my $result = $self->find($wanted);
	119	return $result ? 1 : $result;
	120	}
	121
6036a254	122	#-----------------------------------------------------------------------------
f5eeac3b	123
60108aef CD	124	sub filename {
	125	my ($self) = @_;
	126	return $self->{_doc}->can('filename') ? $self->{_doc}->filename : undef;
	127	}
	128
6036a254	129	#-----------------------------------------------------------------------------
60108aef	130
267b39b4 ES	131	sub highest_explicit_perl_version {
	132	my ($self) = @_;
	133
	134	my $highest_explicit_perl_version =
	135	$self->{_highest_explicit_perl_version};
	136
	137	if ( not exists $self->{_highest_explicit_perl_version} ) {
	138	my $includes = $self->find( \&_is_a_version_statement );
	139
	140	if ($includes) {
1ebef5a9 ES	141	# Note: this will complain about underscores, e.g. "use
	142	# 5.008_000". However, nothing important should be depending upon
	143	# alpha perl versions and marking non-alpha versions as alpha is
	144	# bad in and of itself. Note that this contradicts an example in
	145	# perlfunc about "use".
267b39b4 ES	146	$highest_explicit_perl_version =
	147	max map { version->new( $_->version() ) } @{$includes};
	148	}
	149	else {
	150	$highest_explicit_perl_version = undef;
	151	}
	152
	153	$self->{_highest_explicit_perl_version} =
	154	$highest_explicit_perl_version;
	155	}
	156
	157	return $highest_explicit_perl_version if $highest_explicit_perl_version;
	158	return;
	159	}
	160
937b8de0 JRT	161	#-----------------------------------------------------------------------------
	162
	163	sub mark_disabled_lines {
	164	my ($self, @site_policies) = @_;
	165	my %disabled_lines = _find_disabled_lines($self->{_doc}, @site_policies);
	166
	167	# Ick. Need to merge the disabled lines hash with the shebang lines
	168	# that we alread disabled during the _unfix_shebang() process. Need
	169	# to find a better way to express this.
	170
	171	$self->{_disabled_lines} = { %{$self->{_disabled_lines}}, %disabled_lines };
	172	return $self;
	173	}
	174
	175	#-----------------------------------------------------------------------------
	176
afb2d8f5	177	sub is_line_disabled {
937b8de0 JRT	178	my ($self, $line, $policy_name) = @_;
	179	return 0 if not exists $self->{_disabled_lines}->{$line};
	180	return 1 if $self->{_disabled_lines}->{$line}->{$policy_name};
	181	return 1 if $self->{_disabled_lines}->{$line}->{ALL};
	182	return 0;
	183	}
	184
	185	#-----------------------------------------------------------------------------
	186
267b39b4 ES	187	sub _is_a_version_statement {
	188	my (undef, $element) = @_;
	189
	190	return 0 if not $element->isa('PPI::Statement::Include');
	191	return 1 if $element->version();
	192	return 0;
	193	}
	194
	195	#-----------------------------------------------------------------------------
	196
58a9e587 JRT	197	sub _caching_finder {
	198
	199	my $cache_ref = shift; # These vars will persist for the life
	200	my %isa_cache = (); # of the code ref that this sub returns
	201
	202
	203	# Gather up all the PPI elements and sort by @ISA. Note: if any
	204	# instances used multiple inheritance, this implementation would
	205	# lead to multiple copies of $element in the $elements_of lists.
	206	# However, PPI::* doesn't do multiple inheritance, so we are safe
	207
	208	return sub {
6e7d6c9f	209	my (undef, $element) = @_;
58a9e587 JRT	210	my $classes = $isa_cache{ref $element};
	211	if ( !$classes ) {
	212	$classes = [ ref $element ];
	213	# Use a C-style loop because we append to the classes array inside
	214	for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops)
	215	no strict 'refs'; ## no critic(ProhibitNoStrict)
	216	push @{$classes}, @{"$classes->[$i]::ISA"};
	217	$cache_ref->{$classes->[$i]} \|\|= [];
5bf96118	218	}
58a9e587 JRT	219	$isa_cache{$classes->[0]} = $classes;
58a9e587 JRT	220	}
5bf96118	221
58a9e587 JRT	222	for my $class ( @{$classes} ) {
	223	push @{$cache_ref->{$class}}, $element;
	224	}
5bf96118	225
58a9e587 JRT	226	return 0; # 0 tells find() to keep traversing, but not to store this $element
58a9e587 JRT	227	};
5bf96118 CD	228	}
5bf96118 CD	229
6036a254	230	#-----------------------------------------------------------------------------
58a9e587	231
937b8de0 JRT	232	sub _find_disabled_lines {
	233
	234	my ($doc, @site_policies)= @_;
	235
	236	my $nodes_ref = $doc->find('PPI::Token::Comment') \|\| return;
	237	my %disabled_lines;
	238
	239	_disable_shebang_line($nodes_ref, \%disabled_lines, \@site_policies);
	240	_disable_other_lines($nodes_ref, \%disabled_lines, \@site_policies);
	241	return %disabled_lines;
	242	}
	243
	244	#-----------------------------------------------------------------------------
	245
	246	sub _disable_shebang_line {
	247	my ($nodes_ref, $disabled_lines, $site_policies) = @_;
	248
	249	my $shebang_no_critic = qr{\A [#]! .? [#][#] \s no \s+ critic}xms;
	250
	251	# Special case for the very beginning of the file: allow "##no critic" after the shebang
	252	if (0 < @{$nodes_ref}) {
	253	my $loc = $nodes_ref->[0]->location;
	254	if (1 == $loc->[0] && 1 == $loc->[1] && $nodes_ref->[0] =~ $shebang_no_critic) {
	255	my $pragma = shift @{$nodes_ref};
	256	for my $policy (_parse_nocritic_import($pragma, $site_policies)) {
	257	$disabled_lines->{ 1 }->{$policy} = 1;
	258	}
	259	}
	260	}
	261	return;
	262	}
	263
	264	#-----------------------------------------------------------------------------
	265
	266	sub _disable_other_lines {
	267	my ($nodes_ref, $disabled_lines, $site_policies) = @_;
	268
	269	my $no_critic = qr{\A \s* [#][#] \s* no \s+ critic}xms;
	270	my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}xms;
	271
	272	PRAGMA:
	273	for my $pragma ( grep { $_ =~ $no_critic } @{$nodes_ref} ) {
	274
	275	# Parse out the list of Policy names after the
	276	# 'no critic' pragma. I'm thinking of this just
	277	# like a an C<import> argument for real pragmas.
	278	my @no_policies = _parse_nocritic_import($pragma, $site_policies);
	279
	280	# Grab surrounding nodes to determine the context.
	281	# This determines whether the pragma applies to
	282	# the current line or the block that follows.
	283	my $parent = $pragma->parent();
	284	my $grandparent = $parent ? $parent->parent() : undef;
	285	my $sib = $pragma->sprevious_sibling();
	286
	287
	288	# Handle single-line usage on simple statements
	289	if ( $sib && $sib->location->[0] == $pragma->location->[0] ) {
	290	my $line = $pragma->location->[0];
	291	for my $policy ( @no_policies ) {
	292	$disabled_lines->{ $line }->{$policy} = 1;
	293	}
	294	next PRAGMA;
	295	}
296
297
298	# Handle single-line usage on compound statements
299	if ( ref $parent eq 'PPI::Structure::Block' ) {
300	if ( ref $grandparent eq 'PPI::Statement::Compound'
301	\|\| ref $grandparent eq 'PPI::Statement::Sub' ) {
302	if ( $parent->location->[0] == $pragma->location->[0] ) {
303	my $line = $grandparent->location->[0];
304	for my $policy ( @no_policies ) {
305	$disabled_lines->{ $line }->{$policy} = 1;
306	}
307	next PRAGMA;
308	}
309	}
310	}
311
312
313	# Handle multi-line usage. This is either a "no critic" ..
314	# "use critic" region or a block where "no critic" persists
315	# until the end of the scope. The start is the always the "no
316	# critic" which we already found. So now we have to search
317	# for the end.
318
319	my $start = $pragma;
320	my $end = $pragma;
321
322	SIB:
323	while ( my $esib = $end->next_sibling() ) {
324	$end = $esib; # keep track of last sibling encountered in this scope
325	last SIB
326	if $esib->isa('PPI::Token::Comment') && $esib =~ $use_critic;
327	}
328
329	# We either found an end or hit the end of the scope.
330	# Flag all intervening lines
331	for my $line ( $start->location->[0] .. $end->location->[0] ) {
332	for my $policy ( @no_policies ) {
333	$disabled_lines->{ $line }->{$policy} = 1;
334	}
335	}
336	}
337
338	return;
339	}
340
341	#-----------------------------------------------------------------------------
342
343	sub _parse_nocritic_import {
344
345	my ($pragma, $site_policies) = @_;
346
347	my $module = qr{ [\w:]+ }xms;
348	my $delim = qr{ \s* [,\s] \s* }xms;
349	my $qw = qr{ (?: qw )? }xms;
350	my $qualifier = qr{ $qw [(]? \s* ( $module (?: $delim $module)* ) \s* [)]? }xms;
351	my $no_critic = qr{ \#\# \s* no \s+ critic \s* $qualifier }xms; ##no critic(EscapedMetacharacters)
352
353	if ( my ($module_list) = $pragma =~ $no_critic ) {
354	my @modules = split $delim, $module_list;
355
356	# Compose the specified modules into a regex alternation. Wrap each
357	# in a no-capturing group to permit "\|" in the modules specification
358	# (backward compatibility)
359	my $re = join q{\|}, map {"(?:$_)"} @modules;
360	return grep {m/$re/ixms} @{$site_policies};
361	}
362
363	# Default to disabling ALL policies.
364	return qw(ALL);
365	}
366
367	#-----------------------------------------------------------------------------
368
369	sub _unfix_shebang {
370
371	# When you install a script using ExtUtils::MakeMaker or Module::Build, it
372	# inserts some magical code into the top of the file (just after the
373	# shebang). This code allows people to call your script using a shell,
374	# like `sh my_script`. Unfortunately, this code causes several Policy
375	# violations, so we just disable it as if a "## no critic" comment had
376	# been attached.
377
378	my $doc = shift;
379	my $first_stmnt = $doc->schild(0) \|\| return {};
380
381	# Different versions of MakeMaker and Build use slightly different shebang
382	# fixing strings. This matches most of the ones I've found in my own Perl
383	# distribution, but it may not be bullet-proof.
384
385	my $fixin_rx = qr{^eval 'exec .* \$0 \${1\+"\$@"}'\s[\r\n]\sif.+;}ms; ## no critic (RequireExtendedFormatting)
386	if ( $first_stmnt =~ $fixin_rx ) {
387	my $line = $first_stmnt->location()->[0];
388	return { $line => {ALL => 1}, $line + 1 => {ALL => 1} };
389	}
390
391	#No magic shebang was found!
392	return {};
393	}
394
395	#-----------------------------------------------------------------------------
396
5bf96118	397	1;
58a9e587	398
5bf96118 CD	399	__END__
5bf96118 CD	400
a73f4a71 JRT	401	=pod
	402
	403	=for stopwords pre-caches
	404
5bf96118 CD	405	=head1 NAME
5bf96118 CD	406
c728943a	407	Perl::Critic::Document - Caching wrapper around a PPI::Document.
5bf96118	408
267b39b4	409
5bf96118 CD	410	=head1 SYNOPSIS
	411
	412	use PPI::Document;
	413	use Perl::Critic::Document;
	414	my $doc = PPI::Document->new('Foo.pm');
	415	$doc = Perl::Critic::Document->new($doc);
	416	## Then use the instance just like a PPI::Document
	417
267b39b4	418
5bf96118 CD	419	=head1 DESCRIPTION
	420
	421	Perl::Critic does a lot of iterations over the PPI document tree via
	422	the C<PPI::Document::find()> method. To save some time, this class
	423	pre-caches a lot of the common C<find()> calls in a single traversal.
	424	Then, on subsequent requests we return the cached data.
	425
	426	This is implemented as a facade, where method calls are handed to the
	427	stored C<PPI::Document> instance.
	428
267b39b4	429
5bf96118 CD	430	=head1 CAVEATS
	431
	432	This facade does not implement the overloaded operators from
11f53956 ES	433	L<PPI::Document\|PPI::Document> (that is, the C<use overload ...>
	434	work). Therefore, users of this facade must not rely on that syntactic
	435	sugar. So, for example, instead of C<my $source = "$doc";> you should
	436	write C<my $source = $doc->content();>
5bf96118 CD	437
	438	Perhaps there is a CPAN module out there which implements a facade
	439	better than we do here?
	440
267b39b4 ES	441
	442	=head1 CONSTRUCTOR
	443
	444	=over
	445
	446	=item C<< new($doc) >>
	447
	448	Create a new instance referencing a PPI::Document instance.
	449
	450
	451	=back
	452
	453
5bf96118 CD	454	=head1 METHODS
	455
	456	=over
	457
267b39b4	458	=item C<< new($doc) >>
7076e807 CD	459
	460	Create a new instance referencing a PPI::Document instance.
	461
267b39b4 ES	462
267b39b4 ES	463	=item C<< ppi_document() >>
2b6293b2	464
11f53956 ES	465	Accessor for the wrapped PPI::Document instance. Note that altering
	466	this instance in any way can cause unpredictable failures in
	467	Perl::Critic's subsequent analysis because some caches may fall out of
	468	date.
2b6293b2	469
5bf96118	470
267b39b4 ES	471	=item C<< find($wanted) >>
	472
	473	=item C<< find_first($wanted) >>
fb21e21e	474
267b39b4	475	=item C<< find_any($wanted) >>
f5eeac3b	476
fb21e21e	477	If C<$wanted> is a simple PPI class name, then the cache is employed.
f5eeac3b CD	478	Otherwise we forward the call to the corresponding method of the
f5eeac3b CD	479	C<PPI::Document> instance.
5bf96118	480
267b39b4 ES	481
267b39b4 ES	482	=item C<< filename() >>
e7f2d995 CD	483
	484	Returns the filename for the source code if applicable
	485	(PPI::Document::File) or C<undef> otherwise (PPI::Document).
	486
267b39b4 ES	487
267b39b4 ES	488	=item C<< isa( $classname ) >>
242f7b08	489
11f53956 ES	490	To be compatible with other modules that expect to get a
	491	PPI::Document, the Perl::Critic::Document class masquerades as the
	492	PPI::Document class.
242f7b08	493
267b39b4 ES	494
	495	=item C<< highest_explicit_perl_version() >>
	496
11f53956 ES	497	Returns a L<version\|version> object for the highest Perl version
	498	requirement declared in the document via a C<use> or C<require>
	499	statement. Returns nothing if there is no version statement.
267b39b4 ES	500
267b39b4 ES	501
937b8de0 JRT	502	=item C<< mark_disabled_lines( @policy_names ) >>
	503
	504	Scans the document for C<"## no critic"> pseudo-pragmas and builds
	505	an internal table of which of the listed C<@policy_names> have
	506	been disabled at each line. Returns C<$self>.
	507
	508
	509	=item C<< line_is_disabled($line, $policy_name) >>
	510
	511	Returns true if the given C<$policy_name> has been disabled for
	512	at C<$line> in this document. Otherwise, returns false.
	513
	514
5bf96118 CD	515	=back
5bf96118 CD	516
267b39b4	517
5bf96118 CD	518	=head1 AUTHOR
	519
	520	Chris Dolan <cdolan@cpan.org>
	521
267b39b4	522
5bf96118 CD	523	=head1 COPYRIGHT
5bf96118 CD	524
20dfddeb	525	Copyright (c) 2006-2008 Chris Dolan. All rights reserved.
5bf96118 CD	526
	527	This program is free software; you can redistribute it and/or modify
	528	it under the same terms as Perl itself. The full text of this license
	529	can be found in the LICENSE file included with this module.
	530
	531	=cut
737d3b65 CD	532
	533	# Local Variables:
	534	# mode: cperl
	535	# cperl-indent-level: 4
	536	# fill-column: 78
	537	# indent-tabs-mode: nil
	538	# c-indentation-style: bsd
	539	# End:
96fed375	540	# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :