git.maemo.org Git - pkg-perl/blob - deb-src/libperl-critic-perl/libperl-critic-perl-1.088/lib/Perl/Critic/PolicyFactory.pm

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyFactory.pm $
   3 #     $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
   4 #   $Author: clonezone $
   5 # $Revision: 2489 $
   6 ##############################################################################
   7
   8 package Perl::Critic::PolicyFactory;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use English qw(-no_match_vars);
  15
  16 use File::Spec::Unix qw();
  17 use List::MoreUtils qw(any);
  18
  19 use Perl::Critic::Utils qw{
  20     :characters
  21     $POLICY_NAMESPACE
  22     :data_conversion
  23     policy_long_name
  24     policy_short_name
  25     :internal_lookup
  26 };
  27 use Perl::Critic::PolicyConfig;
  28 use Perl::Critic::Exception::AggregateConfiguration;
  29 use Perl::Critic::Exception::Configuration;
  30 use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic };
  31 use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
  32 use Perl::Critic::Exception::Fatal::PolicyDefinition
  33     qw{ throw_policy_definition };
  34 use Perl::Critic::Utils::Constants qw{ :profile_strictness };
  35
  36 use Exception::Class;   # this must come after "use P::C::Exception::*"
  37
  38 our $VERSION = '1.088';
  39
  40 #-----------------------------------------------------------------------------
  41
  42 # Globals.  Ick!
  43 my @SITE_POLICY_NAMES = ();
  44
  45 #-----------------------------------------------------------------------------
  46
  47 # Blech!!!  This is ug-lee.  Belongs in the constructor.  And it shouldn't be
  48 # called "test" mode.
  49 sub import {
  50
  51     my ( $class, %args ) = @_;
  52     my $test_mode = $args{-test};
  53     my $extra_test_policies = $args{'-extra-test-policies'};
  54
  55     if ( not @SITE_POLICY_NAMES ) {
  56         my $eval_worked = eval {
  57             require Module::Pluggable;
  58             Module::Pluggable->import(search_path => $POLICY_NAMESPACE,
  59                                       require => 1, inner => 0);
  60             @SITE_POLICY_NAMES = plugins(); #Exported by Module::Pluggable
  61             1;
  62         };
  63
  64         if (not $eval_worked) {
  65             if ( $EVAL_ERROR ) {
  66                 throw_generic
  67                     qq<Can't load Policies from namespace "$POLICY_NAMESPACE": $EVAL_ERROR>;
  68             }
  69
  70             throw_generic
  71                 qq<Can't load Policies from namespace "$POLICY_NAMESPACE" for an unknown reason.>;
  72         }
  73
  74         if ( not @SITE_POLICY_NAMES ) {
  75             throw_generic
  76                 qq<No Policies found in namespace "$POLICY_NAMESPACE".>;
  77         }
  78     }
  79
  80     # In test mode, only load native policies, not third-party ones
  81     if ( $test_mode && any {m/\b blib \b/xms} @INC ) {
  82         @SITE_POLICY_NAMES = _modules_from_blib( @SITE_POLICY_NAMES );
  83
  84         if ($extra_test_policies) {
  85             my @extra_policy_full_names =
  86                 map { "${POLICY_NAMESPACE}::$_" } @{$extra_test_policies};
  87
  88             push @SITE_POLICY_NAMES, @extra_policy_full_names;
  89         }
  90     }
  91
  92     return 1;
  93 }
  94
  95 #-----------------------------------------------------------------------------
  96 # Some static helper subs
  97
  98 sub _modules_from_blib {
  99     my (@modules) = @_;
 100     return grep { _was_loaded_from_blib( _module2path($_) ) } @modules;
 101 }
 102
 103 sub _module2path {
 104     my $module = shift || return;
 105     return File::Spec::Unix->catdir(split m/::/xms, $module) . '.pm';
 106 }
 107
 108 sub _was_loaded_from_blib {
 109     my $path = shift || return;
 110     my $full_path = $INC{$path};
 111     return $full_path && $full_path =~ m/ (?: \A | \b b ) lib \b /xms;
 112 }
 113
 114 #-----------------------------------------------------------------------------
 115
 116 sub new {
 117
 118     my ( $class, %args ) = @_;
 119     my $self = bless {}, $class;
 120     $self->_init( %args );
 121     return $self;
 122 }
 123
 124 #-----------------------------------------------------------------------------
 125
 126 sub _init {
 127
 128     my ($self, %args) = @_;
 129
 130     my $profile = $args{-profile};
 131     $self->{_profile} = $profile
 132         or throw_internal q{The -profile argument is required};
 133
 134     my $incoming_errors = $args{-errors};
 135     my $profile_strictness = $args{'-profile-strictness'};
 136     $profile_strictness ||= $PROFILE_STRICTNESS_DEFAULT;
 137
 138     if ( $profile_strictness ne $PROFILE_STRICTNESS_QUIET ) {
 139         my $errors;
 140
 141         # If we're supposed to be strict or problems have already been found...
 142         if (
 143                 $profile_strictness eq $PROFILE_STRICTNESS_FATAL
 144             or  ( $incoming_errors and @{ $incoming_errors->exceptions() } )
 145         ) {
 146             $errors =
 147                 $incoming_errors
 148                     ? $incoming_errors
 149                     : Perl::Critic::Exception::AggregateConfiguration->new();
 150         }
 151
 152         $self->_validate_policies_in_profile( $errors );
 153
 154         if (
 155                 not $incoming_errors
 156             and $errors
 157             and $errors->has_exceptions()
 158         ) {
 159             $errors->rethrow();
 160         }
 161     }
 162
 163     return $self;
 164 }
 165
 166 #-----------------------------------------------------------------------------
 167
 168 sub create_policy {
 169
 170     my ($self, %args ) = @_;
 171
 172     my $policy_name = $args{-name}
 173         or throw_internal q{The -name argument is required};
 174
 175     # Normalize policy name to a fully-qualified package name
 176     $policy_name = policy_long_name( $policy_name );
 177     my $policy_short_name = policy_short_name( $policy_name );
 178
 179
 180     # Get the policy parameters from the user profile if they were
 181     # not given to us directly.  If none exist, use an empty hash.
 182     my $profile = $self->_profile();
 183     my $policy_config;
 184     if ( $args{-params} ) {
 185         $policy_config =
 186             Perl::Critic::PolicyConfig->new(
 187                 $policy_short_name, $args{-params}
 188             );
 189     }
 190     else {
 191         $policy_config = $profile->policy_params($policy_name);
 192         $policy_config ||=
 193             Perl::Critic::PolicyConfig->new( $policy_short_name );
 194     }
 195
 196     # Pull out base parameters.
 197     return _instantiate_policy( $policy_name, $policy_config );
 198 }
 199
 200 #-----------------------------------------------------------------------------
 201
 202 sub create_all_policies {
 203
 204     my ( $self, $incoming_errors ) = @_;
 205
 206     my $errors =
 207         $incoming_errors
 208             ? $incoming_errors
 209             : Perl::Critic::Exception::AggregateConfiguration->new();
 210     my @policies;
 211
 212     foreach my $name ( site_policy_names() ) {
 213         my $policy = eval { $self->create_policy( -name => $name ) };
 214
 215         $errors->add_exception_or_rethrow( $EVAL_ERROR );
 216
 217         if ( $policy ) {
 218             push @policies, $policy;
 219         }
 220     }
 221
 222     if ( not $incoming_errors and $errors->has_exceptions() ) {
 223         $errors->rethrow();
 224     }
 225
 226     return @policies;
 227 }
 228
 229 #-----------------------------------------------------------------------------
 230
 231 sub site_policy_names {
 232     return sort @SITE_POLICY_NAMES;
 233 }
 234
 235 #-----------------------------------------------------------------------------
 236
 237 sub _profile {
 238     my ($self) = @_;
 239
 240     return $self->{_profile};
 241 }
 242
 243 #-----------------------------------------------------------------------------
 244
 245 # This two-phase initialization is caused by the historical lack of a
 246 # requirement for Policies to invoke their super-constructor.
 247 sub _instantiate_policy {
 248     my ($policy_name, $policy_config) = @_;
 249
 250     my $policy = eval { $policy_name->new( %{$policy_config} ) };
 251     _handle_policy_instantiation_exception(
 252         $policy_name,
 253         $policy,        # Note: being used as a boolean here.
 254         $EVAL_ERROR,
 255     );
 256
 257     $policy->__set_config( $policy_config );
 258
 259     my $eval_worked = eval { $policy->__set_base_parameters(); 1; };
 260     _handle_policy_instantiation_exception(
 261         $policy_name, $eval_worked, $EVAL_ERROR,
 262     );
 263
 264     return $policy;
 265 }
 266
 267 sub _handle_policy_instantiation_exception {
 268     my ($policy_name, $eval_worked, $eval_error) = @_;
 269
 270     if (not $eval_worked) {
 271         if ($eval_error) {
 272             my $exception = Exception::Class->caught();
 273
 274             if (ref $exception) {
 275                 $exception->rethrow();
 276             }
 277
 278             throw_policy_definition
 279                 qq<Unable to create policy "$policy_name": $eval_error>;
 280         }
 281
 282         throw_policy_definition
 283             qq<Unable to create policy "$policy_name" for an unknown reason.>;
 284     }
 285
 286     return;
 287 }
 288
 289 #-----------------------------------------------------------------------------
 290
 291 sub _validate_policies_in_profile {
 292     my ($self, $errors) = @_;
 293
 294     my $profile = $self->_profile();
 295     my %known_policies = hashify( $self->site_policy_names() );
 296
 297     for my $policy_name ( $profile->listed_policies() ) {
 298         if ( not exists $known_policies{$policy_name} ) {
 299             my $message = qq{Policy "$policy_name" is not installed.};
 300
 301             if ( $errors ) {
 302                 $errors->add_message( $message );
 303             }
 304             else {
 305                 warn qq{$message\n};
 306             }
 307         }
 308     }
 309
 310     return;
 311 }
 312
 313 #-----------------------------------------------------------------------------
 314
 315 1;
 316
 317 __END__
 318
 319
 320 =pod
 321
 322 =for stopwords PolicyFactory -params
 323
 324 =head1 NAME
 325
 326 Perl::Critic::PolicyFactory - Instantiates Policy objects.
 327
 328 =head1 DESCRIPTION
 329
 330 This is a helper class that instantiates L<Perl::Critic::Policy> objects with
 331 the user's preferred parameters. There are no user-serviceable parts here.
 332
 333 =head1 CONSTRUCTOR
 334
 335 =over 8
 336
 337 =item C<< new( -profile => $profile, -errors => $config_errors ) >>
 338
 339 Returns a reference to a new Perl::Critic::PolicyFactory object.
 340
 341 B<-profile> is a reference to a L<Perl::Critic::UserProfile> object.  This
 342 argument is required.
 343
 344 B<-errors> is a reference to an instance of L<Perl::Critic::ConfigErrors>.
 345 This argument is optional.  If specified, than any problems found will be
 346 added to the object.
 347
 348 =back
 349
 350 =head1 METHODS
 351
 352 =over 8
 353
 354 =item C<< create_policy( -name => $policy_name, -params => \%param_hash ) >>
 355
 356 Creates one Policy object.  If the object cannot be instantiated, it will
 357 throw a fatal exception.  Otherwise, it returns a reference to the new Policy
 358 object.
 359
 360 B<-name> is the name of a L<Perl::Critic::Policy> subclass module.  The
 361 C<'Perl::Critic::Policy'> portion of the name can be omitted for brevity.
 362 This argument is required.
 363
 364 B<-params> is an optional reference to hash of parameters that will be passed
 365 into the constructor of the Policy.  If C<-params> is not defined, we will use
 366 the appropriate Policy parameters from the L<Perl::Critic::UserProfile>.
 367
 368 Note that the Policy will not have had
 369 L<Perl::Critic::Policy/"initialize_if_enabled"> invoked on it, so it may not
 370 yet be usable.
 371
 372 =item C< create_all_policies() >
 373
 374 Constructs and returns one instance of each L<Perl::Critic::Policy> subclass
 375 that is installed on the local system.  Each Policy will be created with the
 376 appropriate parameters from the user's configuration profile.
 377
 378 Note that the Policies will not have had
 379 L<Perl::Critic::Policy/"initialize_if_enabled"> invoked on them, so they may
 380 not yet be usable.
 381
 382 =back
 383
 384 =head1 SUBROUTINES
 385
 386 Perl::Critic::PolicyFactory has a few static subroutines that are used
 387 internally, but may be useful to you in some way.
 388
 389 =over 8
 390
 391 =item C<site_policy_names()>
 392
 393 Returns a list of all the Policy modules that are currently installed in the
 394 Perl::Critic:Policy namespace.  These will include modules that are
 395 distributed with Perl::Critic plus any third-party modules that have been
 396 installed.
 397
 398 =back
 399
 400 =head1 AUTHOR
 401
 402 Jeffrey Ryan Thalhammer <thaljef@cpan.org>
 403
 404 =head1 COPYRIGHT
 405
 406 Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer.  All rights reserved.
 407
 408 This program is free software; you can redistribute it and/or modify it under
 409 the same terms as Perl itself.  The full text of this license can be found in
 410 the LICENSE file included with this module.
 411
 412 =cut
 413
 414 # Local Variables:
 415 #   mode: cperl
 416 #   cperl-indent-level: 4
 417 #   fill-column: 78
 418 #   indent-tabs-mode: nil
 419 #   c-indentation-style: bsd
 420 # End:
 421 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :