Perl::Critic::PolicyFactory - Instantiates Policy objects.

##############################################################################
#      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic/lib/Perl/Critic/PolicyFactory.pm $
#     $Date: 2011-05-15 16:34:46 -0500 (Sun, 15 May 2011) $
#   $Author: clonezone $
# $Revision: 4078 $
##############################################################################

package Perl::Critic::PolicyFactory;

use 5.006001;
use strict;
use warnings;

use English qw(-no_match_vars);

use File::Spec::Unix qw();
use List::MoreUtils qw(any);

use Perl::Critic::Utils qw{
    :characters
    $POLICY_NAMESPACE
    :data_conversion
    policy_long_name
    policy_short_name
    :internal_lookup
};
use Perl::Critic::PolicyConfig;
use Perl::Critic::Exception::AggregateConfiguration;
use Perl::Critic::Exception::Configuration;
use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic };
use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
use Perl::Critic::Exception::Fatal::PolicyDefinition
    qw{ throw_policy_definition };
use Perl::Critic::Exception::Configuration::NonExistentPolicy qw< >;
use Perl::Critic::Utils::Constants qw{ :profile_strictness };

use Exception::Class;   # this must come after "use P::C::Exception::*"

our $VERSION = '1.116';

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

# Globals.  Ick!
my @site_policy_names = ();

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

# Blech!!!  This is ug-lee.  Belongs in the constructor.  And it shouldn't be
# called "test" mode.
sub import {

    my ( $class, %args ) = @_;
    my $test_mode = $args{-test};
    my $extra_test_policies = $args{'-extra-test-policies'};

    if ( not @site_policy_names ) {
        my $eval_worked = eval {
            require Module::Pluggable;
            Module::Pluggable->import(search_path => $POLICY_NAMESPACE,
                                      require => 1, inner => 0);
            @site_policy_names = plugins(); #Exported by Module::Pluggable
            1;
        };

        if (not $eval_worked) {
            if ( $EVAL_ERROR ) {
                throw_generic
                    qq<Can't load Policies from namespace "$POLICY_NAMESPACE": $EVAL_ERROR>;
            }

            throw_generic
                qq<Can't load Policies from namespace "$POLICY_NAMESPACE" for an unknown reason.>;
        }

        if ( not @site_policy_names ) {
            throw_generic
                qq<No Policies found in namespace "$POLICY_NAMESPACE".>;
        }
    }

    # In test mode, only load native policies, not third-party ones
    if ( $test_mode && any {m/\b blib \b/xms} @INC ) {
        @site_policy_names = _modules_from_blib( @site_policy_names );

        if ($extra_test_policies) {
            my @extra_policy_full_names =
                map { "${POLICY_NAMESPACE}::$_" } @{$extra_test_policies};

            push @site_policy_names, @extra_policy_full_names;
        }
    }

    return 1;
}

#-----------------------------------------------------------------------------
# Some static helper subs

sub _modules_from_blib {
    my (@modules) = @_;
    return grep { _was_loaded_from_blib( _module2path($_) ) } @modules;
}

sub _module2path {
    my $module = shift || return;
    return File::Spec::Unix->catdir(split m/::/xms, $module) . '.pm';
}

sub _was_loaded_from_blib {
    my $path = shift || return;
    my $full_path = $INC{$path};
    return $full_path && $full_path =~ m/ (?: \A | \b b ) lib \b /xms;
}

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

sub new {

    my ( $class, %args ) = @_;
    my $self = bless {}, $class;
    $self->_init( %args );
    return $self;
}

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

sub _init {

    my ($self, %args) = @_;

    my $profile = $args{-profile};
    $self->{_profile} = $profile
        or throw_internal q{The -profile argument is required};

    my $incoming_errors = $args{-errors};
    my $profile_strictness = $args{'-profile-strictness'};
    $profile_strictness ||= $PROFILE_STRICTNESS_DEFAULT;
    $self->{_profile_strictness} = $profile_strictness;

    if ( $profile_strictness ne $PROFILE_STRICTNESS_QUIET ) {
        my $errors;

        # If we're supposed to be strict or problems have already been found...
        if (
                $profile_strictness eq $PROFILE_STRICTNESS_FATAL
            or  ( $incoming_errors and @{ $incoming_errors->exceptions() } )
        ) {
            $errors =
                $incoming_errors
                    ? $incoming_errors
                    : Perl::Critic::Exception::AggregateConfiguration->new();
        }

        $self->_validate_policies_in_profile( $errors );

        if (
                not $incoming_errors
            and $errors
            and $errors->has_exceptions()
        ) {
            $errors->rethrow();
        }
    }

    return $self;
}

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

sub create_policy {

    my ($self, %args ) = @_;

    my $policy_name = $args{-name}
        or throw_internal q{The -name argument is required};

    # Normalize policy name to a fully-qualified package name
    $policy_name = policy_long_name( $policy_name );
    my $policy_short_name = policy_short_name( $policy_name );


    # Get the policy parameters from the user profile if they were
    # not given to us directly.  If none exist, use an empty hash.
    my $profile = $self->_profile();
    my $policy_config;
    if ( $args{-params} ) {
        $policy_config =
            Perl::Critic::PolicyConfig->new(
                $policy_short_name, $args{-params}
            );
    }
    else {
        $policy_config = $profile->policy_params($policy_name);
        $policy_config ||=
            Perl::Critic::PolicyConfig->new( $policy_short_name );
    }

    # Pull out base parameters.
    return $self->_instantiate_policy( $policy_name, $policy_config );
}

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

sub create_all_policies {

    my ( $self, $incoming_errors ) = @_;

    my $errors =
        $incoming_errors
            ? $incoming_errors
            : Perl::Critic::Exception::AggregateConfiguration->new();
    my @policies;

    foreach my $name ( site_policy_names() ) {
        my $policy = eval { $self->create_policy( -name => $name ) };

        $errors->add_exception_or_rethrow( $EVAL_ERROR );

        if ( $policy ) {
            push @policies, $policy;
        }
    }

    if ( not $incoming_errors and $errors->has_exceptions() ) {
        $errors->rethrow();
    }

    return @policies;
}

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

sub site_policy_names {
    my @sorted_policy_names = sort @site_policy_names;
    return @sorted_policy_names;
}

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

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

    return $self->{_profile};
}

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

# This two-phase initialization is caused by the historical lack of a
# requirement for Policies to invoke their super-constructor.
sub _instantiate_policy {
    my ($self, $policy_name, $policy_config) = @_;

    $policy_config->set_profile_strictness( $self->{_profile_strictness} );

    my $policy = eval { $policy_name->new( %{$policy_config} ) };
    _handle_policy_instantiation_exception(
        $policy_name,
        $policy,        # Note: being used as a boolean here.
        $EVAL_ERROR,
    );

    $policy->__set_config( $policy_config );

    my $eval_worked = eval { $policy->__set_base_parameters(); 1; };
    _handle_policy_instantiation_exception(
        $policy_name, $eval_worked, $EVAL_ERROR,
    );

    return $policy;
}

sub _handle_policy_instantiation_exception {
    my ($policy_name, $eval_worked, $eval_error) = @_;

    if (not $eval_worked) {
        if ($eval_error) {
            my $exception = Exception::Class->caught();

            if (ref $exception) {
                $exception->rethrow();
            }

            throw_policy_definition
                qq<Unable to create policy "$policy_name": $eval_error>;
        }

        throw_policy_definition
            qq<Unable to create policy "$policy_name" for an unknown reason.>;
    }

    return;
}

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

sub _validate_policies_in_profile {
    my ($self, $errors) = @_;

    my $profile = $self->_profile();
    my %known_policies = hashify( $self->site_policy_names() );

    for my $policy_name ( $profile->listed_policies() ) {
        if ( not exists $known_policies{$policy_name} ) {
            my $message = qq{Policy "$policy_name" is not installed.};

            if ( $errors ) {
                $errors->add_exception(
                    Perl::Critic::Exception::Configuration::NonExistentPolicy->new(
                        policy  => $policy_name,
                    )
                );
            }
            else {
                warn qq{$message\n};
            }
        }
    }

    return;
}

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

1;

__END__

# 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 :