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