--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyFactory.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+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::Utils::Constants qw{ :profile_strictness };
+
+use Exception::Class; # this must come after "use P::C::Exception::*"
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+# 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;
+
+ 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 _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 {
+ return sort @SITE_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 ($policy_name, $policy_config) = @_;
+
+ 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_message( $message );
+ }
+ 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> objects with
+the user's preferred parameters. There are no user-serviceable parts here.
+
+=head1 CONSTRUCTOR
+
+=over 8
+
+=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> object. This
+argument is required.
+
+B<-errors> is a reference to an instance of L<Perl::Critic::ConfigErrors>.
+This argument is optional. If specified, than any problems found will be
+added to the object.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=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> 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>.
+
+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> 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 8
+
+=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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
projects / dh-make-perl / blobdiff