view release on metacpan or  search on metacpan

lib/Config/Model/CheckList.pm  view on Meta::CPAN

#
# This file is part of Config-Model
#
# This software is Copyright (c) 2005-2022 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::CheckList 2.166;

use Mouse;
use 5.020;

use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;

use Config::Model::Exception;
use Config::Model::IdElementReference;
use Config::Model::Warper;
use List::MoreUtils qw/any none/;
use Carp;
use Log::Log4perl qw(get_logger :levels);
use Storable qw/dclone/;

extends qw/Config::Model::AnyThing/;

with "Config::Model::Role::WarpMaster";
with "Config::Model::Role::Grab";
with "Config::Model::Role::HelpAsText";
with "Config::Model::Role::ComputeFunction";
with "Config::Model::Role::Utils";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";

my $logger = get_logger("Tree.Element.CheckList");
my $user_logger   = get_logger("User");

my @introspect_params = qw/refer_to computed_refer_to/;

my @accessible_params = qw/default_list upstream_default_list choice ordered/;
my @allowed_warp_params = ( @accessible_params, qw/level/ );

has [qw/data preset layered/] => ( is => 'rw', isa => 'HashRef', default => sub { {}; } );
has computed_refer_to => ( is => 'rw', isa => 'Maybe[HashRef]' );
has [qw/refer_to/]            => ( is => 'rw', isa => 'Str' );
has [qw/ordered_data choice/] => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } );
has [qw/ordered/]             => ( is => 'ro', isa => 'Bool' );

has [qw/warp help/] => ( is => 'rw', isa => 'Maybe[HashRef]' );

around BUILDARGS => sub {
    my $orig  = shift;
    my $class = shift;
    my %args  = @_;
    my %h     = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @allowed_warp_params;
    return $class->$orig( backup => dclone( \%h ), @_ );
};

# used by roles
sub allowed_warp_params {
    return @allowed_warp_params;
}

sub BUILD {
    my $self = shift;

    if ( defined $self->refer_to or defined $self->computed_refer_to ) {
        $self->submit_to_refer_to();
    }

    $self->set_properties();    # set will use backup data

    if ( defined $self->warp ) {
        my $warp_info = $self->warp;
        $self->{warper} = Config::Model::Warper->new(
            warped_object => $self,
            %$warp_info,
            allowed => \@allowed_warp_params
        );
    }

    $self->cl_init;

    $logger->info( "Created check_list element " . $self->element_name );
    return $self;
}

sub cl_init {
    my $self = shift;

    $self->warp if ( $self->{warp} );

    if ( defined $self->{ref_object} ) {
        my $level = $self->parent->get_element_property(
            element  => $self->{element_name},
            property => 'level',
        );
        $self->{ref_object}->get_choice_from_referred_to if $level ne 'hidden';
    }
    return;
}

sub name {
    my $self = shift;
    my $name = $self->{parent}->name . ' ' . $self->{element_name};
    return $name;
}

sub value_type { return 'check_list'; }

# warning : call to 'set' are not cumulative. Default value are always
# restored. Lest keeping track of what was modified with 'set' is
# too hard for the user.
sub set_properties ($self, %raw_args) {
    # cleanup all parameters that are handled by warp
    for (@allowed_warp_params) {
        delete $self->{$_};
    }

    if ( $logger->is_trace() ) {
        my $keys = join( ',', keys %raw_args );
        $logger->trace("set_properties called on $self->{element_name} with $keys");
    }

    # merge data passed to set_properties with data passed to the constructor
    my %args = $self->merge_properties(%raw_args);

    # these are handled by Node or Warper
    for (qw/level/) {
        delete $args{$_}
    }

lib/Config/Model/CheckList.pm  view on Meta::CPAN

    return;
}

sub get_info {
    my $self = shift;

    my @items = ('type: check_list');
    if ( defined $self->refer_to ) {
        push @items, "refer_to: " . $self->refer_to;
    }
    push @items, "ordered: " . ( $self->ordered ? 'yes' : 'no' );
    return @items;
}

sub clear {
    my $self = shift;
    # also triggers notify changes
    for my $item ($self->get_choice) {
        $self->clear_item($item);
    }
    return;
}

sub clear_values { goto &clear; }

sub clear_layered {
    my $self = shift;
    $self->{layered} = {};
    return;
}

my %old_mode = ( built_in_list => 'upstream_default_list', );

sub get_checked_list_as_hash ($self, @args) {
    my %args = _resolve_arg_shortcut(\@args, 'mode');
    my $mode = $args{mode} || '';

    foreach my $k ( keys %old_mode ) {
        next unless $mode eq $k;
        $mode = $old_mode{$k};
        carp $self->location, " warning: deprecated mode parameter: $k, ", "expected $mode\n";
    }

    if ( my $err = $self->is_bad_mode($mode)) {
        croak "get_checked_list_as_hash: $err";
    }

    my $dat = $self->{data};
    my $pre = $self->{preset};
    my $def = $self->{default_data};
    my $lay = $self->{layered};
    my $ud  = $self->{upstream_default_data};

    # fill empty hash result
    my %h = map { $_ => 0 } $self->get_choice;

    my %predef = ( %$def, %$pre );
    my %std = ( %$ud, %$lay, %$def, %$pre );

    # use _std_backup if all data values are null (no checked items by user)
    my %old_dat = ( none { $_; } values %$dat ) ? %{ $self->{_std_backup} || {} } : %$dat;

    if ( not $mode and any { $_; } values %predef and none { $_; } values %old_dat ) {

        # changed from nothing to default checked list that must be written
        $self->{_std_backup} = { %$def, %$pre };
        $self->notify_change( note => "use default checklist" );
    }

    # custom test must compare the whole list at once, not just one item at a time.
    my %result =
        $mode eq 'custom' ? ( ( grep { $dat->{$_} xor $std{$_} } keys %h ) ? ( %$pre, %$dat ) : () )
        : $mode eq 'preset'           ? (%$pre)
        : $mode eq 'layered'          ? (%$lay)
        : $mode eq 'upstream_default' ? (%$ud)
        : $mode eq 'default'          ? (%$def)
        : $mode eq 'standard'         ? %std
        : $mode eq 'user'             ? ( %h, %std, %$dat )
        :                               ( %predef, %$dat );

    return wantarray ? %result : \%result;
}

sub get_checked_list ($self, @args) {
    my %h          = $self->get_checked_list_as_hash(@args);
    my @good_order = $self->{ordered} ? @{ $self->{ordered_data} } : sort keys %h;
    my @res        = grep { $h{$_} } @good_order;
    return wantarray ? @res : \@res;
}

sub fetch ($self, @args) {
    return join( ',', $self->get_checked_list(@args) );
}

sub fetch_custom {
    my $self = shift;
    return join( ',', $self->get_checked_list('custom') );
}

sub fetch_preset {
    my $self = shift;
    return join( ',', $self->get_checked_list('preset') );
}

sub fetch_layered {
    my $self = shift;
    return join( ',', $self->get_checked_list('layered') );
}

sub get ($self, $path, @args){
    if ($path) {
        Config::Model::Exception::User->throw(
            object  => $self,
            message => "get() called with a value with non-empty path: '$path'"
        );
    }
    return $self->fetch(@args);
}

sub set {
    my ($self, $path, $list, %args) = @_;

    my $check_validity = $self->_check_check( $args{check} );
    if ($path) {
        Config::Model::Exception::User->throw(
            object  => $self,