libconfig-model-perl 2.047-1 / usr / share / perl5 / Config / Model / HashId.pm

#
# This file is part of Config-Model
#
# This software is Copyright (c) 2013 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::HashId ;
{
  $Config::Model::HashId::VERSION = '2.047';
}
use Mouse ;
use namespace::autoclean;

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

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

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

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

has data => ( is => 'rw', isa => 'HashRef' , default => sub { {} ;} ) ;
has list => ( is => 'rw', isa => 'ArrayRef', default => sub { [] ;} ) ;

has [qw/default_keys auto_create_keys/] => ( is => 'rw', isa => 'ArrayRef', default => sub { [] ;} ) ;
has [qw/morph ordered/] => (is => 'ro', isa => 'Bool' ) ;

sub BUILD {
    my $self = shift;

    # 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 {
    my $self = shift ;

    $self->SUPER::set_properties(@_) ;

    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
    # warp mechanism
    foreach my $k (sort keys %$data) {
        next unless $wrong->($k) ;
        $logger->debug("set_properties: ",$self->name," deleting id $k");
        delete $data->{$k}  ;
    }
}

sub _migrate {
    my $self = shift;

    return if $self->{migration_done};
    
    # migration must be done *after* initial load to make sure that all data
    # were retrieved from the file before migration. 
    return if $self->instance->initial_load ;
    $self->{migration_done} = 1;
    
    if ($self->{migrate_keys_from}) { 
        my $followed = $self->safe_typed_grab(param => 'migrate_keys_from', check => 'no') ;
        if ($logger->is_debug) {
            $logger ->debug($self->name," migrate keys from ",$followed->name);
        }

        map { $self->_store($_, undef) unless $self->_defined($_) } $followed -> fetch_all_indexes ;
    }
    elsif ( $self->{migrate_values_from}) {
        my $followed = $self->safe_typed_grab(param => 'migrate_values_from', check => 'no') ;
        $logger ->debug($self->name," migrate values from ",$followed->name) if $logger->is_debug;
        foreach my $item ( $followed -> fetch_all_indexes ) {
            next if $self->exists($item) ; # don't clobber existing entries
            my $data = $followed->fetch_with_id($item) -> dump_as_data(check => 'no') ;
            $self->fetch_with_id($item)->load_data($data) ;
        }
    }

}

sub get_type {
    my $self = shift;
    return 'hash' ;
}


# important: return the actual size (not taking into account auto-created stuff)
sub fetch_size {
    my $self = shift;
    return scalar keys %{$self->{data}} ;
}

sub _fetch_all_indexes {
    my $self = shift;
    return $self->{ordered} ? @{$self->{list}}
      :                    sort keys %{$self->{data}} ;
}

# fetch without any check 
sub _fetch_with_id {
    my ($self,$key) = @_ ;
    my $i = $self->instance ;
    return $self->{data}{$key};
}

# store without any check
sub _store {
    my ($self, $key, $value) =  @_ ;
    push @{$self->{list}}, $key 
      unless exists $self->{data}{$key};
    return $self->{data}{$key} = $value ;
}

sub _exists {
    my ($self,$key) = @_ ;
    return exists $self->{data}{$key};
}

sub _defined {
    my ($self,$key) = @_ ;
    return defined $self->{data}{$key} ? 1 : 0;
}

#internal
sub auto_create_elements {
    my $self = shift ;

    my $auto_p = $self->auto_create_keys ;
    return unless defined $auto_p ;
    # create empty slots
    map {
        $self->_store($_, undef) unless exists $self->{data}{$_};
    }  (ref $auto_p ? @$auto_p : ($auto_p)) ;
}

# internal
sub create_default {
    my $self = shift ;
    my @temp = keys %{$self->{data}} ;

    return if @temp ;

    # hash is empty so create empty element for default keys
    my $def = $self->get_default_keys ;
    map {$self->_store($_,undef) } @$def ;
    $self->create_default_with_init ;
}    

sub _delete {
    my ($self,$key) = @_ ;

    # remove key in ordered list
    @{$self->{list}} = grep { $_ ne $key } @{ $self->{list}} ;

    return delete $self->{data}{$key};
}

sub remove {
    my $self = shift ;
    $self->delete(@_) ;
}

sub _clear {
    my ($self) = @_ ;
    $self->{list} = [];
    $self->{data} = {};
}


# hash only method
sub firstkey {
    my $self = shift ;

    $self->warp 
      if ($self->{warp} and @{$self->{warp_info}{computed_master}});

    $self->create_default if defined $self->{default};

    # reset "each" iterator (to be sure, map is also an iterator)
    my @list = $self->_fetch_all_indexes ;
    $self->{each_list} = \@list ;
    return shift @list ;
}


# hash only method
sub nextkey {
    my $self = shift ;

    $self->warp 
      if ($self->{warp} and @{$self->{warp_info}{computed_master}});

    my $res =  shift @{$self->{each_list}} ;

    return $res if defined $res ;

    # reset list for next call to next_keys
    $self->{each_list} = [ $self->_fetch_all_indexes  ] ;

    return ;
}


sub swap {
    my $self = shift ;
    my ($key1,$key2) = @_ ;

    foreach my $k (@_) {
        Config::Model::Exception::User
            -> throw (
                      object => $self,
                      message => "swap: unknow key $k"
                     )
              unless exists $self->{data}{$k} ;
    }

    my @copy = @{$self->{list}} ;
    for (my $idx = 0; $idx <= $#copy; $idx ++ ) {
        if ($copy[$idx] eq $key1) {
            $self->{list}[$idx] = $key2 ;
        }
        if ($copy[$idx] eq $key2) {
            $self->{list}[$idx] = $key1 ;
        }
    }

    $self->notify_change(note => "swap ordered hash keys $key1 and $key2")
}


sub move {
    my $self = shift ;
    my ($from,$to) = @_ ;

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

    my $ok = $self->check_idx($to) ;

    if ($ok) {
        # this may clobber the old content of $self->{data}{$to}
        $self->{data}{$to} = delete $self->{data}{$from} ;
        delete $self->{warning_hash}{$from} ;
        # update index_value attribute in moved objects
        $self->{data}{$to}->index_value($to) ;
        
        $self->notify_change(note => "rename key from $from to $to");

        # data_mode is preset or layered or user. Actually only user
        # mode makes sense here
        my $imode = $self->instance->get_data_mode ;
        $self->set_data_mode( $to, $imode ) ;

        my ($to_idx,$from_idx);
        my $idx = 0 ;
        my $list = $self->{list} ;
        map { $to_idx   = $idx if $list->[$idx] eq $to;
              $from_idx = $idx if $list->[$idx] eq $from;
              $idx ++ ;
          } @$list ;

        if (defined $to_idx) {
            # Since $to is clobbered, $from takes its place in the list
            $list->[$from_idx] = $to ;
            # and the $from entry is removed from the list
            splice @$list,$to_idx,1;
        } else {
            # $to is moved in the place of from in the list
            $list->[$from_idx] = $to ;
        }
    } else {
        Config::Model::Exception::WrongValue 
            -> throw (
                      error => join("\n\t",@{$self->{error}}),
                      object => $self
                     ) ;
    }
}




sub move_after {
    my $self = shift ;
    my ($key_to_move,$ref_key) = @_ ;

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

    foreach my $k (@_) {
        Config::Model::Exception::User
            -> throw (
                      object => $self,
                      message => "swap: unknow key $k"
                     )
              unless exists $self->{data}{$k} ;
    }

    # remove the key to move in ordered list
    @{$self->{list}} = grep { $_ ne $key_to_move } @{ $self->{list}} ;

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

    my $msg ;
    if (defined $ref_key) {
        for (my $idx = 0; $idx <= $#$list; $idx ++ ) {
            if ($list->[$idx] eq $ref_key) {
                splice @$list ,$idx+1,0, $key_to_move ;
                last;
            }
        }

        $msg = "moved key $key_to_move after $ref_key" ;
    } else {
        unshift @$list , $key_to_move ;
        $msg = "moved key $key_to_move at beginning" ;
    }


    $self->notify_change( note => $msg ) ;

}


sub move_up {
    my $self = shift ;
    my ($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
}


sub move_down {
    my $self = shift ;
    my ($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
}


sub load_data {
    my $self = shift ;
    my %args = @_ > 1 ? @_ : ( data => shift) ;
    my $data       = delete $args{data};
    my $check = $self->_check_check($args{check}) ;

    if (ref ($data) eq 'HASH') {
        my @load_keys ;
        my $from = ''; ;

        if ($self->{ordered} and defined $data->{__order}) {
            @load_keys = @{ delete $data->{__order} };
            $from = ' with __order' ;
        } elsif ($self->{ordered}) {
            $logger->warn("HashId ".$self->location.": loading ordered "
                          ."hash from hash ref without special key '__order'. Element "
                          ."order is not defined");
            $from = ' without __order' ;
        }

        @load_keys = sort keys %$data unless @load_keys;

        $logger->info("HashId load_data (".$self->location.
                      ") will load idx @load_keys from hash ref".$from);
        foreach my $elt (@load_keys) {
            my $obj = $self->fetch_with_id($elt) ;
            $obj -> load_data(%args, data => $data->{$elt}) ;
        }
    }
    elsif ( $self->{ordered} and ref ($data) eq 'ARRAY') {
        $logger->info("HashId load_data (".$self->location
                      .") will load idx 0..$#$data from array ref") ;
        my $idx = 0 ;
        while ( $idx < @$data ) {
            my $elt = $data->[$idx++];
            my $obj = $self->fetch_with_id($elt) ;
            $obj -> load_data(%args, data => $data->[$idx++]) ;
        }
    }
    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 ,
                     ) ;
    }
}

__PACKAGE__->meta->make_immutable;

1;

# ABSTRACT: Handle hash element for configuration model

__END__

=pod

=encoding UTF-8

=head1 NAME

Config::Model::HashId - Handle hash element for configuration model

=head1 VERSION

version 2.047

=head1 SYNOPSIS

See L<Config::Model::AnyId/SYNOPSIS>

=head1 DESCRIPTION

This class provides hash elements for a L<Config::Model::Node>.

The hash index can either be en enumerated type, a boolean, an integer
or a string.

=head1 CONSTRUCTOR

HashId object should not be created directly.

=head1 Hash model declaration

See
L<model declaration section|Config::Model::AnyId/"Hash or list model declaration">
from L<Config::Model::AnyId>.

=head1 Methods

=head2 get_type

Returns C<hash>.

=head2 fetch_size

Returns the number of elements of the hash.

=head2 firstkey

Returns the first key of the hash. Behaves like C<each> core perl
function.

=head2 nextkey

Returns the next key of the hash. Behaves like C<each> core perl
function.

=head2 swap ( key1 , key2 )

Swap the order of the 2 keys. Ignored for non ordered hash.

=head2 move ( key1 , key2 )

Rename key1 in key2. 

=head2 move_after ( key_to_move [ , after_this_key ] )

Move the first key after the second one. If the second parameter is
omitted, the first key is placed in first position. Ignored for non
ordered hash.

=head2 move_up ( key )

Move the key up in a ordered hash. Attempt to move up the first key of
an ordered hash will be ignored. Ignored for non ordered hash.

=head2 move_down ( key )

Move the key down in a ordered hash. Attempt to move up the last key of
an ordered hash will be ignored. Ignored for non ordered hash.

=head2 load_data ( data => ( hash_ref | array_ref ) [ , check => ... , ... ])

Load check_list as a hash ref for standard hash. 

Ordered hash should be loaded with an array ref or with a hash
containing a special C<__order> element. E.g. loaded with either:

  [ a => 'foo', b => 'bar' ]

or

  { __order => ['a','b'], b => 'bar', a => 'foo' }

load_data can also be called with a single ref parameter.

=head1 AUTHOR

Dominique Dumont, (ddumont at cpan dot org)

=head1 SEE ALSO

L<Config::Model>, 
L<Config::Model::Instance>, 
L<Config::Model::AnyId>,
L<Config::Model::ListId>,
L<Config::Model::Value>

=head1 AUTHOR

Dominique Dumont

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2013 by Dominique Dumont.

This is free software, licensed under:

  The GNU Lesser General Public License, Version 2.1, February 1999

=cut