File Coverage

blib/lib/Perl/Critic/UserProfile.pm

Criterion	Covered	Total	%
statement	120	128	93.7
branch	16	26	61.5
condition	18	30	60.0
subroutine	29	30	96.6
pod	8	8	100.0
total	191	222	86.0

package Perl::Critic::UserProfile;

use 5.010001;
use strict;
use warnings;

use Readonly;

use Config::Tiny qw();
use File::Spec qw();

use Perl::Critic::OptionsProcessor qw();
use Perl::Critic::Utils qw{ $EMPTY policy_long_name policy_short_name };
use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
use Perl::Critic::Exception::Configuration::Generic qw{ throw_generic };
use Perl::Critic::PolicyConfig;

our $VERSION = '1.150';

#-----------------------------------------------------------------------------

sub new {

    my ( $class, %args ) = @_;
    my $self = bless {}, $class;
    $self->_init( %args );
    return $self;
}

#-----------------------------------------------------------------------------

sub _init {

    my ( $self, %args ) = @_;
    # The profile can be defined, undefined, or an empty string.
    my $profile = $args{-profile} // _find_profile_path();
    $self->_load_profile( $profile );
    $self->_set_options_processor();
    return $self;
}

#-----------------------------------------------------------------------------

sub options_processor {

    my ($self) = @_;
    return $self->{_options_processor};
}

#-----------------------------------------------------------------------------

sub policy_params {

    my ( $self, $policy ) = @_;

    my $short_name = policy_short_name($policy);

    return Perl::Critic::PolicyConfig->new(
        $short_name,
        $self->raw_policy_params($policy),
    );
}

#-----------------------------------------------------------------------------

sub raw_policy_params {

    my ( $self, $policy ) = @_;
    my $profile = $self->{_profile};
    my $long_name  = ref $policy || policy_long_name( $policy );
    my $short_name = policy_short_name( $long_name );

    return
            $profile->{$short_name}
        ||  $profile->{$long_name}
        ||  $profile->{"-$short_name"}
        ||  $profile->{"-$long_name"}
        ||  {};
}

#-----------------------------------------------------------------------------

sub policy_is_disabled {

    my ( $self, $policy ) = @_;
    my $profile = $self->{_profile};
    my $long_name  = ref $policy || policy_long_name( $policy );
    my $short_name = policy_short_name( $long_name );

    return exists $profile->{"-$short_name"}
        || exists $profile->{"-$long_name"};
}

#-----------------------------------------------------------------------------

sub policy_is_enabled {

    my ( $self, $policy ) = @_;
    my $profile = $self->{_profile};
    my $long_name  = ref $policy || policy_long_name( $policy );
    my $short_name = policy_short_name( $long_name );

    return exists $profile->{$short_name}
        || exists $profile->{$long_name};
}

#-----------------------------------------------------------------------------

sub listed_policies {

    my ( $self, $policy ) = @_;
    my @normalized_policy_names;

    for my $policy_name ( sort keys %{$self->{_profile}} ) {
        $policy_name =~ s/\A - //xmso; #Chomp leading "-"
        my $policy_long_name = policy_long_name( $policy_name );
        push @normalized_policy_names, $policy_long_name;
    }

    return @normalized_policy_names;
}

#-----------------------------------------------------------------------------

sub source {
    my ( $self ) = @_;

    return $self->{_source};
}

sub _set_source {
    my ( $self, $source ) = @_;

    $self->{_source} = $source;

    return;
}

#-----------------------------------------------------------------------------
# Begin PRIVATE methods

Readonly::Hash my %LOADER_FOR => (
    ARRAY   => \&_load_profile_from_array,
    DEFAULT => \&_load_profile_from_file,
    HASH    => \&_load_profile_from_hash,
    SCALAR  => \&_load_profile_from_string,
);

sub _load_profile {

    my ( $self, $profile ) = @_;

    my $ref_type = ref $profile || 'DEFAULT';
    my $loader = $LOADER_FOR{$ref_type};

    if (not $loader) {
        throw_internal qq{Can't load UserProfile from type "$ref_type"};
    }

    $self->{_profile} = $loader->($self, $profile);
    return $self;
}

#-----------------------------------------------------------------------------

sub _set_options_processor {

    my ($self) = @_;
    my $profile = $self->{_profile};
    my $defaults = delete $profile->{__defaults__} || {};
    $self->{_options_processor} =
        Perl::Critic::OptionsProcessor->new( %{ $defaults } );
    return $self;
}

#-----------------------------------------------------------------------------

sub _load_profile_from_file {
    my ( $self, $file ) = @_;

    # Handle special cases.
    return {} if not defined $file;
    return {} if $file eq $EMPTY;
    return {} if $file eq 'NONE';

    $self->_set_source( $file );

    my $profile = Config::Tiny->read( $file );
    if (not defined $profile) {
        my $errstr = Config::Tiny::errstr();
        throw_generic
            message => qq{Could not parse profile "$file": $errstr},
            source  => $file;
    }

    _fix_defaults_key( $profile );

    return $profile;
}

#-----------------------------------------------------------------------------

sub _load_profile_from_array {
    my ( $self, $array_ref ) = @_;
    my $joined    = join qq{\n}, @{ $array_ref };
    my $profile = Config::Tiny->read_string( $joined );

    if (not defined $profile) {
        throw_generic 'Profile error: ' . Config::Tiny::errstr();
    }

    _fix_defaults_key( $profile );

    return $profile;
}

#-----------------------------------------------------------------------------

sub _load_profile_from_string {
    my ( $self, $string ) = @_;
    my $profile = Config::Tiny->read_string( ${ $string } );

    if (not defined $profile) {
        throw_generic 'Profile error: ' . Config::Tiny::errstr();
    }

    _fix_defaults_key( $profile );

    return $profile;
}

#-----------------------------------------------------------------------------

sub _load_profile_from_hash {
    my ( $self, $hash_ref ) = @_;
    return $hash_ref;
}

#-----------------------------------------------------------------------------

sub _find_profile_path {

    #Check explicit environment setting
    return $ENV{PERLCRITIC} if exists $ENV{PERLCRITIC};

    #Define default filename
    my $rc_file = '.perlcriticrc';

    #Check current directory
    return $rc_file if -f $rc_file;

    #Check home directory
    if ( my $home_dir = _find_home_dir() ) {
        my $path = File::Spec->catfile( $home_dir, $rc_file );
        return $path if -f $path;
    }

    #No profile defined
    return;
}

#-----------------------------------------------------------------------------

sub _find_home_dir {
    # This logic is taken from File::HomeDir::Tiny.
    return
        ($^O eq 'MSWin32') && ("$]" < 5.016)  ## no critic ( Variables::ProhibitPunctuationVars ValuesAndExpressions::ProhibitMagicNumbers ValuesAndExpressions::ProhibitMismatchedOperators )
            ? ($ENV{HOME} || $ENV{USERPROFILE})
            : (<~>)[0];
}

#-----------------------------------------------------------------------------

# !$%@$%^ Config::Tiny uses a completely non-descriptive name for global
# values.
sub _fix_defaults_key {
    my ( $profile ) = @_;

    my $defaults = delete $profile->{_};
    if ($defaults) {
        $profile->{__defaults__} = $defaults;
    }

    return;
}

1;

__END__

#-----------------------------------------------------------------------------

=pod

=for stopwords UserProfile

=head1 NAME

Perl::Critic::UserProfile - The contents of the user's profile, often F<.perlcriticrc>.


=head1 DESCRIPTION

This is a helper class that encapsulates the contents of the user's
profile, which is usually stored in a F<.perlcriticrc> file. There are
no user-serviceable parts here.


=head1 INTERFACE SUPPORT

This is considered to be a non-public class.  Its interface is subject
to change without notice.


=head1 CONSTRUCTOR

=over

=item C<< new( -profile => $p ) >>

B<-profile> is the path to the user's profile.  If -profile is not
defined, then it looks for the profile at F<./.perlcriticrc> and then
F<$HOME/.perlcriticrc>.  If neither of those files exists, then the
UserProfile is created with default values.

This object does not take into account any command-line overrides;
L<Perl::Critic::Config|Perl::Critic::Config> does that.


=back


=head1 METHODS

=over

=item C< options_processor() >

Returns the
L<Perl::Critic::OptionsProcessor|Perl::Critic::OptionsProcessor>
object for this UserProfile.


=item C< policy_is_disabled( $policy ) >

Given a reference to a L<Perl::Critic::Policy|Perl::Critic::Policy>
object or the name of one, returns true if the user has disabled that
policy in their profile.


=item C< policy_is_enabled( $policy ) >

Given a reference to a L<Perl::Critic::Policy|Perl::Critic::Policy>
object or the name of one, returns true if the user has explicitly
enabled that policy in their user profile.


=item C< policy_params( $policy ) >

Given a reference to a L<Perl::Critic::Policy|Perl::Critic::Policy>
object or the name of one, returns a
L<Perl::Critic::PolicyConfig|Perl::Critic::PolicyConfig> for the
user's configuration parameters for that policy.


=item C< raw_policy_params( $policy ) >

Given a reference to a L<Perl::Critic::Policy|Perl::Critic::Policy>
object or the name of one, returns a reference to a hash of the user's
configuration parameters for that policy.


=item C< listed_policies() >

Returns a list of the names of all the Policies that are mentioned in
the profile.  The Policy names will be fully qualified (e.g.
Perl::Critic::Foo).


=item C< source() >

The place where the profile information came from, if available.
Usually the path to a F<.perlcriticrc>.


=back


=head1 SEE ALSO

L<Perl::Critic::Config|Perl::Critic::Config>,
L<Perl::Critic::OptionsProcessor|Perl::Critic::OptionsProcessor>


=head1 AUTHOR

Jeffrey Ryan Thalhammer <[e-mail]>


=head1 COPYRIGHT

Copyright (c) 2005-2023 Imaginative Software Systems.

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 :