Added -forced-filename option to the P::C::Document contstructor.

[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 Carp qw< confess >;

use List::Util qw< reduce >;
use Scalar::Util qw< blessed refaddr weaken >;
use version;

use PPI::Document;
use PPI::Document::File;
use PPIx::Utilities::Node qw< split_ppi_node_by_namespace >;

use Perl::Critic::Annotation;
use Perl::Critic::Exception::Parse qw< throw_parse >;
use Perl::Critic::Utils qw< :booleans :characters shebang_line >;

use PPIx::Regexp 0.010 qw< >;

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

our $VERSION = '1.110';

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

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, @args) = @_;

    my $self = bless {}, $class;

    $self->_init_common();
    $self->_init_from_external_source(@args);

    return $self;
}

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

sub _new_for_parent_document {
    my ($class, $ppi_document, $parent_document) = @_;

    my $self = bless {}, $class;

    $self->_init_common();

    $self->{_doc}       = $ppi_document;
    $self->{_is_module} = $parent_document->is_module();

    return $self;
}

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

sub _init_common {
    my ($self) = @_;
    my %args;

    $self->{_annotations} = [];
    $self->{_suppressed_violations} = [];
    $self->{_disabled_line_map} = {};

    return;
}

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

sub _init_from_external_source { ## no critic (Subroutines::RequireArgUnpacking)
    my $self = shift;
    my %args;

    if (@_ == 1) {
        warnings::warnif(
            'deprecated',
            'Perl::Critic::Document->new($source) deprecated, use Perl::Critic::Document->new(-source => $source) instead.' ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
        );
        %args = ('-source' => shift);
    } else {
        %args = @_;
    }

    my $source_code = $args{'-source'};

    # $source_code can be a file name, or a reference to a
    # PPI::Document, or a reference to a scalar containing source
    # code.  In the last case, PPI handles the translation for us.

    my $ppi_document =
        _is_ppi_doc($source_code)
            ? $source_code
            : ref $source_code
                ? PPI::Document->new($source_code)
                : PPI::Document::File->new($source_code);

    # Bail on error
    if (not defined $ppi_document) {
        my $errstr   = PPI::Document::errstr();
        my $file     = ref $source_code ? undef : $source_code;
        throw_parse
            message     => qq<Can't parse code: $errstr>,
            file_name   => $file;
    }

    $self->{_doc} = $ppi_document;
    $self->index_locations();
    $self->_disable_shebang_fix();
    $self->{_forced_filename} = $args{'-forced-filename'};
    $self->{_is_module} = $self->_determine_is_module(\%args);

    return;
}

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

sub _is_ppi_doc {
    my ($ref) = @_;
    return blessed($ref) && $ref->isa('PPI::Document');
}

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

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 namespaces {
    my ($self) = @_;

    return keys %{ $self->_nodes_by_namespace() };
}

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

sub subdocuments_for_namespace {
    my ($self, $namespace) = @_;

    my $subdocuments = $self->_nodes_by_namespace()->{$namespace};

    return $subdocuments ? @{$subdocuments} : ();
}

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

sub ppix_regexp_from_element {
    my ( $self, $element ) = @_;

    if ( blessed( $element ) && $element->isa( 'PPI::Element' ) ) {
        my $addr = refaddr( $element );
        return $self->{_ppix_regexp_from_element}{$addr}
            if exists $self->{_ppix_regexp_from_element}{$addr};
        return ( $self->{_ppix_regexp_from_element}{$addr} =
            PPIx::Regexp->new( $element ) );
    } else {
        return PPIx::Regexp->new( $element );
    }
}

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

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

    if ($self->{_forced_filename}) {
        return $self->{_forced_filename};
    }
    else {
        my $doc = $self->{_doc};
        return $doc->can('filename') ? $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 doesn't use List::Util::max() because that function
            # doesn't use the overloaded ">=" etc of a version object.  The
            # reduce() style lets version.pm take care of all comparing.
            #
            # For reference, max() ends up looking at the string converted to
            # an NV, or something like that.  An underscore like "5.005_04"
            # provokes a warning and is chopped off at "5.005" thus losing the
            # minor part from the comparison.
            #
            # An underscore "5.005_04" is supposed to mean an alpha release
            # and shouldn't be used in a perl version.  But it's shown in
            # perlfunc under "use" (as a number separator), and appears in
            # several modules supplied with perl 5.10.0 (like version.pm
            # itself!).  At any rate if version.pm can understand it then
            # that's enough for here.
            $highest_explicit_perl_version =
                reduce { $a >= $b ? $a : $b }
                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 uses_module {
    my ($self, $module_name) = @_;

    return exists $self->_modules_used()->{$module_name};
}

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

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

    my @annotations = Perl::Critic::Annotation->create_annotations($self);
    $self->add_annotation(@annotations);
    return $self;
}

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

sub line_is_disabled_for_policy {
    my ($self, $line, $policy) = @_;
    my $policy_name = ref $policy || $policy;

    # HACK: This Policy is special.  If it is active, it cannot be
    # disabled by a "## no critic" annotation.  Rather than create a general
    # hook in Policy.pm for enabling this behavior, we chose to hack
    # it here, since this isn't the kind of thing that most policies do

    return 0 if $policy_name eq
        'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic';

    return 1 if $self->{_disabled_line_map}->{$line}->{$policy_name};
    return 1 if $self->{_disabled_line_map}->{$line}->{ALL};
    return 0;
}

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

sub add_annotation {
    my ($self, @annotations) = @_;

    # Add annotation to our private map for quick lookup
    for my $annotation (@annotations) {

        my ($start, $end) = $annotation->effective_range();
        my @affected_policies = $annotation->disables_all_policies ?
            qw(ALL) : $annotation->disabled_policies();

        # TODO: Find clever way to do this with hash slices
        for my $line ($start .. $end) {
            for my $policy (@affected_policies) {
                $self->{_disabled_line_map}->{$line}->{$policy} = 1;
            }
        }
    }

    push @{ $self->{_annotations} }, @annotations;
    return $self;
}

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

sub annotations {
    my ($self) = @_;
    return @{ $self->{_annotations} };
}

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

sub add_suppressed_violation {
    my ($self, $violation) = @_;
    push @{$self->{_suppressed_violations}}, $violation;
    return $self;
}

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

sub suppressed_violations {
    my ($self) = @_;
    return @{ $self->{_suppressed_violations} };
}

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

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

    return not $self->is_module();
}

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

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

    return $self->{_is_module};
}

#-----------------------------------------------------------------------------
# PRIVATE functions & methods

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 _disable_shebang_fix {
    my ($self) = @_;

    # When you install a program 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 program using a shell,
    # like `sh my_script`.  Unfortunately, this code causes several Policy
    # violations, so we disable them as if they had "## no critic" annotations.

    my $first_stmnt = $self->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 (ExtendedFormatting)
    if ( $first_stmnt =~ $fixin_rx ) {
        my $line = $first_stmnt->location->[0];
        $self->{_disabled_line_map}->{$line}->{ALL} = 1;
        $self->{_disabled_line_map}->{$line + 1}->{ALL} = 1;
    }

    return $self;
}

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

sub _determine_is_module {
    my ($self, $args) = @_;

    my $file_name = $self->filename();
    if (
            defined $file_name
        and ref $args->{'-program-extensions'} eq 'ARRAY'
    ) {
        foreach my $ext ( @{ $args->{'-program-extensions'} } ) {
            my $regex =
                ref $ext eq 'Regexp'
                    ? $ext
                    : qr< @{ [ quotemeta $ext ] } \z >xms;

            return $FALSE if $file_name =~ m/$regex/smx;
        }
    }

    return $FALSE if shebang_line($self);
    return $FALSE if defined $file_name && $file_name =~ m/ [.] PL \z /smx;

    return $TRUE;
}

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

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

    my $nodes = $self->{_nodes_by_namespace};

    return $nodes if $nodes;

    my $ppi_document = $self->ppi_document();
    if (not $ppi_document) {
        return $self->{_nodes_by_namespace} = {};
    }

    my $raw_nodes_map = split_ppi_node_by_namespace($ppi_document);

    my %wrapped_nodes;
    while ( my ($namespace, $raw_nodes) = each %{$raw_nodes_map} ) {
        $wrapped_nodes{$namespace} = [
            map { __PACKAGE__->_new_for_parent_document($_, $self) }
                @{$raw_nodes}
        ];
    }

    return $self->{_nodes_by_namespace} = \%wrapped_nodes;
}

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

# Note: must use exists on return value to determine membership because all
# the values are false, unlike the result of hashify().
sub _modules_used {
    my ($self) = @_;

    my $mapping = $self->{_modules_used};

    return $mapping if $mapping;

    my $includes = $self->find('PPI::Statement::Include');
    if (not $includes) {
        return $self->{_modules_used} = {};
    }

    my %mapping;
    for my $module (
        grep { $_ } map  { $_->module() || $_->pragma() } @{$includes}
    ) {
        # Significanly ess memory than $h{$k} => 1.  Thanks Mr. Lembark.
        $mapping{$module} = ();
    }

    return $self->{_modules_used} = \%mapping;
}

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

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(-source => $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 INTERFACE SUPPORT

This is considered to be a public class.  Any changes to its interface
will go through a deprecation cycle.


=head1 CONSTRUCTOR

=over

=item C<< new(-source => $source_code, '-forced-filename' => $filename, '-program-extensions' => [program_extensions]) >>

Create a new instance referencing a PPI::Document instance.  The
C<$source_code> can be the name of a file, a reference to a scalar
containing actual source code, or a L<PPI::Document|PPI::Document> or
L<PPI::Document::File|PPI::Document::File>.

In the event that C<$source_code> is a reference to a scalar containing
actual source code or a L<PPI::Document|PPI::Document>, the resulting
L<Perl::Critic::Document|Perl::Critic::Document> will not have a filename.
This may cause L<Perl::Critic::Document|Perl::Critic::Document> to incorrectly
classify the source code as a module or script.  To avoid this problem, you
can optionally set the C<-forced-filename> to force the L<Perl::Critic::Document|Perl::Critic::Document>
to have a particular C<$filename>.  Do not use this option if C<$source_code>
is already the name of a file, or is a reference to a L<PPI::Document::File|PPI::Document::File>.

The '-program-extensions' argument is optional, and is a reference to a list
of strings and/or regular expressions. The strings will be made into regular
expressions matching the end of a file name, and any document whose file name
matches one of the regular expressions will be considered a program.

If -program-extensions is not specified, or if it does not determine the
document type, the document will be considered to be a program if the source
has a shebang line or its file name (if any) matches C<< m/ [.] PL \z /smx >>.

=back

=head1 METHODS

=over

=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) >>

Caching wrappers around the PPI methods.  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<< namespaces() >>

Returns a list of the namespaces (package names) in the document.


=item C<< subdocuments_for_namespace($namespace) >>

Returns a list of sub-documents containing the elements in the given
namespace.  For example, given that the current document is for the source

    foo();
    package Foo;
    package Bar;
    package Foo;

this method will return two L<Perl::Critic::Document|Perl::Critic::Document>s
for a parameter of C<"Foo">.  For more, see
L<PPIx::Utilities::Node/split_ppi_node_by_namespace>.


=item C<< ppix_regexp_from_element($element) >>

Caching wrapper around C<< PPIx::Regexp->new($element) >>.  If
C<$element> is a C<PPI::Element> the cache is employed, otherwise it
just returns the results of C<< PPIx::Regexp->new() >>.  In either case,
it returns C<undef> unless the argument is something that
L<PPIx::Regexp|PPIx::Regexp> actually understands.


=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<< uses_module($module_or_pragma_name) >>

Answers whether there is a C<use>, C<require>, or C<no> of the given name in
this document.  Note that there is no differentiation of modules vs. pragmata
here.


=item C<< process_annotations() >>

Causes this Document to scan itself and mark which lines &
policies are disabled by the C<"## no critic"> annotations.


=item C<< line_is_disabled_for_policy($line, $policy_object) >>

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


=item C<< add_annotation( $annotation ) >>

Adds an C<$annotation> object to this Document.


=item C<< annotations() >>

Returns a list containing all the
L<Perl::Critic::Annotation|Perl::Critic::Annotation>s that
were found in this Document.


=item C<< add_suppressed_violation($violation) >>

Informs this Document that a C<$violation> was found but not reported
because it fell on a line that had been suppressed by a C<"## no critic">
annotation. Returns C<$self>.


=item C<< suppressed_violations() >>

Returns a list of references to all the
L<Perl::Critic::Violation|Perl::Critic::Violation>s
that were found in this Document but were suppressed.


=item C<< is_program() >>

Returns whether this document is considered to be a program.


=item C<< is_module() >>

Returns whether this document is considered to be a Perl module.

=back

=head1 AUTHOR

Chris Dolan <cdolan@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2006-2010 Chris Dolan.

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 :