view release on metacpan or  search on metacpan

lib/Config/Model/HashId.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::HashId 2.166;

use Mouse;
use 5.20.0;

use Config::Model::Exception;
use Carp;

use Mouse::Util::TypeConstraints;
use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;


subtype 'HaskKeyArray' => as 'ArrayRef' ;
coerce 'HaskKeyArray' => from 'Str' => via { [$_] } ;

use Log::Log4perl qw(get_logger :levels);

my $logger = get_logger("Tree::Element::Id::Hash");

extends qw/Config::Model::AnyId/;

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

has data => ( is => 'rw', isa => 'HashRef',  default => sub { {}; } );
has list => (
    is => 'rw',
    isa => 'ArrayRef[Str]',
    traits     => ['Array'],
    default => sub { []; },
    handles => {
        _sort => 'sort_in_place',
    }
);

has [qw/default_keys auto_create_keys/] => (
    is => 'rw',
    isa => 'HaskKeyArray',
    coerce => 1,
    default => sub { []; }
);
has [qw/ordered write_empty_value/] => ( is => 'ro', isa => 'Bool', default => 0 );

sub BUILD ($self,$) {

    # foreach my $wrong (qw/migrate_values_from/) {
    # Config::Model::Exception::Model->throw (
    # object => $self,
    # error =>  "Cannot use $wrong with ".$self->get_type." element"
    # ) if defined $self->{$wrong};
    # }

    # could use "required", but we'd get a Moose error instead of a Config::Model
    # error
    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "Undefined index_type"
    ) unless defined $self->index_type;

    return $self;
}

sub set_properties ($self, @args) {
    $self->SUPER::set_properties(@args);

    my $idx_type = $self->{index_type};

    # remove unwanted items
    my $data = $self->{data};

    my $idx   = 1;
    my $wrong = sub {
        my $k = shift;
        if ( $idx_type eq 'integer' ) {
            return 1 if defined $self->{max_index} and $k > $self->{max_index};
            return 1 if defined $self->{min_index} and $k < $self->{min_index};
        }
        return 1 if defined $self->{max_nb} and $idx++ > $self->{max_nb};
        return 0;
    };

    # delete entries that no longer fit the constraints imposed by the

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

}

sub move_up ($self, $key) {
    if ( not $self->ordered ) {
        $logger->warn("called move_up on unordered hash");
        return;
    }

    Config::Model::Exception::User->throw(
        object  => $self,
        message => "move_up: unknow key $key"
    ) unless exists $self->{data}{$key};

    my $list = $self->{list};

    # we start from 1 as we can't move up idx 0
    for ( my $idx = 1 ; $idx < scalar @$list ; $idx++ ) {
        if ( $list->[$idx] eq $key ) {
            $list->[$idx] = $list->[ $idx - 1 ];
            $list->[ $idx - 1 ] = $key;
            $self->notify_change( note => "moved up key '$key'" );
            last;
        }
    }

    # notify_change is placed in the loop so the notification
    # is not sent if the user tries to move up idx 0
    return;
}

sub move_down ($self, $key) {
    if ( not $self->ordered ) {
        $logger->warn("called move_down on unordered hash");
        return;
    }

    Config::Model::Exception::User->throw(
        object  => $self,
        message => "move_down: unknown key $key"
    ) unless exists $self->{data}{$key};

    my $list = $self->{list};

    # we end at $#$list -1  as we can't move down last idx
    for ( my $idx = 0 ; $idx < scalar @$list - 1 ; $idx++ ) {
        if ( $list->[$idx] eq $key ) {
            $list->[$idx] = $list->[ $idx + 1 ];
            $list->[ $idx + 1 ] = $key;
            $self->notify_change( note => "moved down key $key" );
            last;
        }
    }

    # notify_change is placed in the loop so the notification
    # is not sent if the user tries to move past last idx
    return;
}

sub _load_data_from_hash ($self, %args) {
    my $data = $args{data};
    my %backup = %$data ;

    my @ordered_keys;
    my $from = '';

    my $order_key = '__'.$self->element_name.'_order';
    if ( $self->{ordered} and (defined $data->{$order_key} or defined $data->{__order} )) {
        @ordered_keys = @{ delete $data->{$order_key} or delete $data->{__order} };
        $from      = ' with '.$order_key;
    }
    elsif ( $self->{ordered} and (not $data->{__skip_order} and keys %$data > 1)) {
        $logger->warn(
            "HashId " . $self->location . ": loading ordered "
            . "hash from hash ref without special key '__order'. Element "
            . "order is not defined. If needed, this warning can be suppressed by passing "
            . " key '__skip_order' set to 1."
        );
        $from = ' without '.$order_key;
    }
    delete $data->{__skip_order};

    if (@ordered_keys) {
        my %data_keys = map { $_ => 1 ; } keys %$data;
        my @left_keys;
        foreach my $k (@ordered_keys) {
            push @left_keys, $k unless delete $data_keys{$k};
        }
        if ( %data_keys or @left_keys) {
            my @msg ;
            push @msg, "Unlisted keys in __order:", keys %data_keys if %data_keys;
            push @msg, "Extra keys in __order:", @left_keys if @left_keys;
            Config::Model::Exception::LoadData->throw(
                object     => $self,
                message    => "load_data: ordered keys mistmatch: @msg",
                wrong_data => \%backup,
            );
        }
    }
    my @load_keys = @ordered_keys ? @ordered_keys : sort keys %$data;

    $logger->info(
        "HashId load_data (" . $self->location .
            ") will load idx @load_keys from hash ref $from"
    );
    my $res = 0;
    foreach my $elt (@load_keys) {
        my $obj = $self->fetch_with_id($elt);
        $res += $obj->load_data( %args, data => $data->{$elt} ) if defined $data->{$elt};
    }
    return !!$res;
}

sub load_data ($self, @args) {
    my %args = @args > 1 ? @args : ( data => $args[0] );
    my $data  = delete $args{data};
    my $check = $self->_check_check( $args{check} );

    if ( ref($data) eq 'HASH' ) {
        return $self->_load_data_from_hash(data => $data, %args);
    }
    elsif ( ref($data) eq 'ARRAY' ) {
        my $res = 0;
        $logger->info(
            "HashId load_data (" . $self->location . ") will load idx 0..$#$data from array ref" );
        $self->notify_change( note => "Converted ordered data to non ordered", really => 1) unless $self->ordered;
        my $idx = 0;
        while ( $idx < @$data ) {
            my $elt = $data->[ $idx++ ];
            my $obj = $self->fetch_with_id($elt);
            $res += $obj->load_data( %args, data => $data->[ $idx++ ] );
        }
        return !!$res;
    }
    elsif ( defined $data ) {

        # we can skip undefined data
        my $expected = $self->{ordered} ? 'array' : 'hash';
        Config::Model::Exception::LoadData->throw(
            object     => $self,
            message    => "load_data called with non $expected ref arg",
            wrong_data => $data,
        );
    }
    return;
}

__PACKAGE__->meta->make_immutable;

1;

# ABSTRACT: Handle hash element for configuration model

__END__

=pod