File Coverage

blib/lib/Perl/Critic/PolicyFactory.pm

Criterion	Covered	Total	%
statement	145	157	92.3
branch	31	42	73.8
condition	21	31	67.7
subroutine	30	30	100.0
pod	4	4	100.0
total	231	264	87.5

package Perl::Critic::PolicyFactory;

use 5.010001;
use strict;
use warnings;

use English qw(-no_match_vars);

use File::Spec::Unix qw();
use List::SomeUtils 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.146';

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

# 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.  So this
    # filters out any policy that was loaded from within a directory called
    # "blib".  During the usual "./Build test" process this works fine,
    # but it doesn't work if you are using prove to test against the code
    # directly in the lib/ directory.

    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__


=pod

=for stopwords PolicyFactory -params

=head1 NAME

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


=head1 DESCRIPTION

This is a helper class that instantiates
L<Perl::Critic::Policy|Perl::Critic::Policy> objects with the user's
preferred parameters. There are no user-serviceable parts here.


=head1 INTERFACE SUPPORT

This is considered to be a non-public class.  Its interface is subject
to change without notice.


=head1 CONSTRUCTOR

=over

=item C<< new( -profile => $profile, -errors => $config_errors ) >>

Returns a reference to a new Perl::Critic::PolicyFactory object.

B<-profile> is a reference to a
L<Perl::Critic::UserProfile|Perl::Critic::UserProfile> object.  This
argument is required.

B<-errors> is a reference to an instance of
L<Perl::Critic::ConfigErrors|Perl::Critic::ConfigErrors>.  This
argument is optional.  If specified, than any problems found will be
added to the object.


=back


=head1 METHODS

=over

=item C<< create_policy( -name => $policy_name, -params => \%param_hash ) >>

Creates one Policy object.  If the object cannot be instantiated, it
will throw a fatal exception.  Otherwise, it returns a reference to
the new Policy object.

B<-name> is the name of a L<Perl::Critic::Policy|Perl::Critic::Policy>
subclass module.  The C<'Perl::Critic::Policy'> portion of the name
can be omitted for brevity.  This argument is required.

B<-params> is an optional reference to hash of parameters that will be
passed into the constructor of the Policy.  If C<-params> is not
defined, we will use the appropriate Policy parameters from the
L<Perl::Critic::UserProfile|Perl::Critic::UserProfile>.

Note that the Policy will not have had
L<Perl::Critic::Policy/"initialize_if_enabled"> invoked on it, so it
may not yet be usable.


=item C< create_all_policies() >

Constructs and returns one instance of each
L<Perl::Critic::Policy|Perl::Critic::Policy> subclass that is
installed on the local system.  Each Policy will be created with the
appropriate parameters from the user's configuration profile.

Note that the Policies will not have had
L<Perl::Critic::Policy/"initialize_if_enabled"> invoked on them, so
they may not yet be usable.


=back


=head1 SUBROUTINES

Perl::Critic::PolicyFactory has a few static subroutines that are used
internally, but may be useful to you in some way.

=over

=item C<site_policy_names()>

Returns a list of all the Policy modules that are currently installed
in the Perl::Critic:Policy namespace.  These will include modules that
are distributed with Perl::Critic plus any third-party modules that
have been installed.


=back


=head1 AUTHOR

Jeffrey Ryan Thalhammer <[e-mail]>


=head1 COPYRIGHT

Copyright (c) 2005-2011 Imaginative Software Systems

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 :