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

   1 ##############################################################################
   2 #      $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/UserProfile.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::UserProfile;
   9
  10 use 5.006001;
  11 use strict;
  12 use warnings;
  13
  14 use English qw(-no_match_vars);
  15 use Readonly;
  16
  17 use Config::Tiny qw();
  18 use File::Spec qw();
  19
  20 use Perl::Critic::OptionsProcessor qw();
  21 use Perl::Critic::Utils qw{ :characters policy_long_name policy_short_name };
  22 use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
  23 use Perl::Critic::Exception::Configuration::Generic qw{ throw_generic };
  24 use Perl::Critic::PolicyConfig;
  25
  26 our $VERSION = '1.088';
  27
  28 #-----------------------------------------------------------------------------
  29
  30 sub new {
  31
  32     my ( $class, %args ) = @_;
  33     my $self = bless {}, $class;
  34     $self->_init( %args );
  35     return $self;
  36 }
  37
  38 #-----------------------------------------------------------------------------
  39
  40 sub _init {
  41
  42     my ( $self, %args ) = @_;
  43     # The profile can be defined, undefined, or an empty string.
  44     my $profile = defined $args{-profile} ? $args{-profile} : _find_profile_path();
  45     $self->_load_profile( $profile );
  46     $self->_set_options_processor();
  47     return $self;
  48 }
  49
  50 #-----------------------------------------------------------------------------
  51
  52 sub options_processor {
  53
  54     my ($self) = @_;
  55     return $self->{_options_processor};
  56 }
  57
  58 #-----------------------------------------------------------------------------
  59
  60 sub policy_params {
  61
  62     my ( $self, $policy ) = @_;
  63
  64     my $short_name = policy_short_name($policy);
  65
  66     return Perl::Critic::PolicyConfig->new(
  67         $short_name,
  68         $self->raw_policy_params($policy),
  69     );
  70 }
  71
  72 #-----------------------------------------------------------------------------
  73
  74 sub raw_policy_params {
  75
  76     my ( $self, $policy ) = @_;
  77     my $profile = $self->{_profile};
  78     my $long_name  = ref $policy || policy_long_name( $policy );
  79     my $short_name = policy_short_name( $long_name );
  80
  81     return
  82             $profile->{$short_name}
  83         ||  $profile->{$long_name}
  84         ||  $profile->{"-$short_name"}
  85         ||  $profile->{"-$long_name"}
  86         ||  {};
  87 }
  88
  89 #-----------------------------------------------------------------------------
  90
  91 sub policy_is_disabled {
  92
  93     my ( $self, $policy ) = @_;
  94     my $profile = $self->{_profile};
  95     my $long_name  = ref $policy || policy_long_name( $policy );
  96     my $short_name = policy_short_name( $long_name );
  97
  98     return exists $profile->{"-$short_name"}
  99         || exists $profile->{"-$long_name"};
 100 }
 101
 102 #-----------------------------------------------------------------------------
 103
 104 sub policy_is_enabled {
 105
 106     my ( $self, $policy ) = @_;
 107     my $profile = $self->{_profile};
 108     my $long_name  = ref $policy || policy_long_name( $policy );
 109     my $short_name = policy_short_name( $long_name );
 110
 111     return exists $profile->{$short_name}
 112         || exists $profile->{$long_name};
 113 }
 114
 115 #-----------------------------------------------------------------------------
 116
 117 sub listed_policies {
 118
 119     my ( $self, $policy ) = @_;
 120     my @normalized_policy_names = ();
 121
 122     for my $policy_name ( sort keys %{$self->{_profile}} ) {
 123         $policy_name =~ s/\A - //mxo; #Chomp leading "-"
 124         my $policy_long_name = policy_long_name( $policy_name );
 125         push @normalized_policy_names, $policy_long_name;
 126     }
 127
 128     return @normalized_policy_names;
 129 }
 130
 131 #-----------------------------------------------------------------------------
 132
 133 sub source {
 134     my ( $self ) = @_;
 135
 136     return $self->{_source};
 137 }
 138
 139 sub _set_source {
 140     my ( $self, $source ) = @_;
 141
 142     $self->{_source} = $source;
 143
 144     return;
 145 }
 146
 147 #-----------------------------------------------------------------------------
 148 # Begin PRIVATE methods
 149
 150 Readonly::Hash my %LOADER_FOR => (
 151     ARRAY   => \&_load_profile_from_array,
 152     DEFAULT => \&_load_profile_from_file,
 153     HASH    => \&_load_profile_from_hash,
 154     SCALAR  => \&_load_profile_from_string,
 155 );
 156
 157 sub _load_profile {
 158
 159     my ( $self, $profile ) = @_;
 160
 161     my $ref_type = ref $profile || 'DEFAULT';
 162     my $loader = $LOADER_FOR{$ref_type};
 163
 164     if (not $loader) {
 165         throw_internal qq{Can't load UserProfile from type "$ref_type"};
 166     }
 167
 168     $self->{_profile} = $loader->($self, $profile);
 169     return $self;
 170 }
 171
 172 #-----------------------------------------------------------------------------
 173
 174 sub _set_options_processor {
 175
 176     my ($self) = @_;
 177     my $profile = $self->{_profile};
 178     my $defaults = delete $profile->{__defaults__} || {};
 179     $self->{_options_processor} =
 180         Perl::Critic::OptionsProcessor->new( %{ $defaults } );
 181     return $self;
 182 }
 183
 184 #-----------------------------------------------------------------------------
 185
 186 sub _load_profile_from_file {
 187     my ( $self, $file ) = @_;
 188
 189     # Handle special cases.
 190     return {} if not defined $file;
 191     return {} if $file eq $EMPTY;
 192     return {} if $file eq 'NONE';
 193
 194     $self->_set_source( $file );
 195
 196     my $profile = Config::Tiny->read( $file );
 197     if (not defined $profile) {
 198         my $errstr = Config::Tiny::errstr();
 199         throw_generic
 200             message => qq{Could not parse profile "$file": $errstr},
 201             source  => $file;
 202     }
 203
 204     _fix_defaults_key( $profile );
 205
 206     return $profile;
 207 }
 208
 209 #-----------------------------------------------------------------------------
 210
 211 sub _load_profile_from_array {
 212     my ( $self, $array_ref ) = @_;
 213     my $joined    = join qq{\n}, @{ $array_ref };
 214     my $profile = Config::Tiny->read_string( $joined );
 215
 216     if (not defined $profile) {
 217         throw_generic 'Profile error: ' . Config::Tiny::errstr();
 218     }
 219
 220     _fix_defaults_key( $profile );
 221
 222     return $profile;
 223 }
 224
 225 #-----------------------------------------------------------------------------
 226
 227 sub _load_profile_from_string {
 228     my ( $self, $string ) = @_;
 229     my $profile = Config::Tiny->read_string( ${ $string } );
 230
 231     if (not defined $profile) {
 232         throw_generic 'Profile error: ' . Config::Tiny::errstr();
 233     }
 234
 235     _fix_defaults_key( $profile );
 236
 237     return $profile;
 238 }
 239
 240 #-----------------------------------------------------------------------------
 241
 242 sub _load_profile_from_hash {
 243     my ( $self, $hash_ref ) = @_;
 244     return $hash_ref;
 245 }
 246
 247 #-----------------------------------------------------------------------------
 248
 249 sub _find_profile_path {
 250
 251     #Define default filename
 252     my $rc_file = '.perlcriticrc';
 253
 254     #Check explicit environment setting
 255     return $ENV{PERLCRITIC} if exists $ENV{PERLCRITIC};
 256
 257     #Check current directory
 258     return $rc_file if -f $rc_file;
 259
 260     #Check home directory
 261     if ( my $home_dir = _find_home_dir() ) {
 262         my $path = File::Spec->catfile( $home_dir, $rc_file );
 263         return $path if -f $path;
 264     }
 265
 266     #No profile defined
 267     return;
 268 }
 269
 270 #-----------------------------------------------------------------------------
 271
 272 sub _find_home_dir {
 273
 274     # Try using File::HomeDir
 275     if ( eval { require File::HomeDir } ) {
 276         return File::HomeDir->my_home();
 277     }
 278
 279     # Check usual environment vars
 280     for my $key (qw(HOME USERPROFILE HOMESHARE)) {
 281         next if not defined $ENV{$key};
 282         return $ENV{$key} if -d $ENV{$key};
 283     }
 284
 285     # No home directory defined
 286     return;
 287 }
 288
 289 #-----------------------------------------------------------------------------
 290
 291 # !$%@$%^ Config::Tiny uses a completely non-descriptive name for global
 292 # values.
 293 sub _fix_defaults_key {
 294     my ( $profile ) = @_;
 295
 296     my $defaults = delete $profile->{_};
 297     if ($defaults) {
 298         $profile->{__defaults__} = $defaults;
 299     }
 300
 301     return;
 302 }
 303
 304 1;
 305
 306 __END__
 307
 308 #-----------------------------------------------------------------------------
 309
 310 =pod
 311
 312 =for stopwords UserProfile
 313
 314 =head1 NAME
 315
 316 Perl::Critic::UserProfile - The contents of the user's profile, often F<.perlcriticrc>.
 317
 318
 319 =head1 DESCRIPTION
 320
 321 This is a helper class that encapsulates the contents of the user's
 322 profile, which is usually stored in a F<.perlcriticrc> file. There are
 323 no user-serviceable parts here.
 324
 325
 326 =head1 CONSTRUCTOR
 327
 328 =over
 329
 330 =item C< new( -profile => $p ) >
 331
 332 B<-profile> is the path to the user's profile.  If -profile is not
 333 defined, then it looks for the profile at F<./.perlcriticrc> and then
 334 F<$HOME/.perlcriticrc>.  If neither of those files exists, then the
 335 UserProfile is created with default values.
 336
 337 This object does not take into account any command-line overrides;
 338 L<Perl::Critic::Config> does that.
 339
 340
 341 =back
 342
 343
 344 =head1 METHODS
 345
 346 =over
 347
 348 =item C< options_processor() >
 349
 350 Returns the L<Perl::Critic::OptionsProcessor> object for this UserProfile.
 351
 352
 353 =item C< policy_is_disabled( $policy ) >
 354
 355 Given a reference to a L<Perl::Critic::Policy> object or the name of
 356 one, returns true if the user has disabled that policy in their
 357 profile.
 358
 359
 360 =item C< policy_is_enabled( $policy ) >
 361
 362 Given a reference to a L<Perl::Critic::Policy> object or the name of
 363 one, returns true if the user has explicitly enabled that policy in
 364 their user profile.
 365
 366
 367 =item C< policy_params( $policy ) >
 368
 369 Given a reference to a L<Perl::Critic::Policy> object or the name of
 370 one, returns a L<Perl::Critic::PolicyConfig> for the user's
 371 configuration parameters for that policy.
 372
 373
 374 =item C< raw_policy_params( $policy ) >
 375
 376 Given a reference to a L<Perl::Critic::Policy> object or the name of
 377 one, returns a reference to a hash of the user's configuration
 378 parameters for that policy.
 379
 380
 381 =item C< listed_policies() >
 382
 383 Returns a list of the names of all the Policies that are mentioned in
 384 the profile.  The Policy names will be fully qualified (e.g.
 385 Perl::Critic::Foo).
 386
 387
 388 =item C< source() >
 389
 390 The place where the profile information came from, if available.
 391 Usually the path to a F<.perlcriticrc>.
 392
 393
 394 =back
 395
 396
 397 =head1 SEE ALSO
 398
 399 L<Perl::Critic::Config>, L<Perl::Critic::OptionsProcessor>
 400
 401
 402 =head1 AUTHOR
 403
 404 Jeffrey Ryan Thalhammer <thaljef@cpan.org>
 405
 406
 407 =head1 COPYRIGHT
 408
 409 Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer.  All rights reserved.
 410
 411 This program is free software; you can redistribute it and/or modify
 412 it under the same terms as Perl itself.  The full text of this license
 413 can be found in the LICENSE file included with this module.
 414
 415 =cut
 416
 417 # Local Variables:
 418 #   mode: cperl
 419 #   cperl-indent-level: 4
 420 #   fill-column: 78
 421 #   indent-tabs-mode: nil
 422 #   c-indentation-style: bsd
 423 # End:
 424 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :