X-Git-Url: http://git.maemo.org/git/?p=dh-make-perl;a=blobdiff_plain;f=dev%2Farm%2Flibperl-critic-perl%2Flibperl-critic-perl-1.088%2Flib%2FPerl%2FCritic%2FPolicyFactory.pm;fp=dev%2Farm%2Flibperl-critic-perl%2Flibperl-critic-perl-1.088%2Flib%2FPerl%2FCritic%2FPolicyFactory.pm;h=eebbf603fb8f5fb9bf845cf890d950fd022e5ccc;hp=0000000000000000000000000000000000000000;hb=f477fa73365d491991707e7ed9217b48d6994551;hpb=da95c414033799c3a62606f299c3c00b5c77ca11 diff --git a/dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/PolicyFactory.pm b/dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/PolicyFactory.pm new file mode 100644 index 0000000..eebbf60 --- /dev/null +++ b/dev/arm/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/PolicyFactory.pm @@ -0,0 +1,421 @@ +############################################################################## +# $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; + } + + throw_generic + qq; + } + + if ( not @SITE_POLICY_NAMES ) { + throw_generic + qq; + } + } + + # 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; + } + + throw_policy_definition + qq; + } + + 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 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 object. This +argument is required. + +B<-errors> is a reference to an instance of L. +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 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. + +Note that the Policy will not have had +L invoked on it, so it may not +yet be usable. + +=item C< create_all_policies() > + +Constructs and returns one instance of each L 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 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 + +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 + +=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 :