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