view release on metacpan or  search on metacpan

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

    traits  => ['Array'],
    handles => {
        add_check_content   => 'push',
        get_all_content_checks => 'elements',
    },
    default => sub { []; }
);

# needs_content_check defaults to 1 to trap bad data right after loading
has needs_content_check => ( is => 'rw', isa => 'Bool', default => 1 );

has has_fixes => (
    is => 'ro',
    isa => 'Num',
    default => 0,
    traits => ['Number'],
    handles => {
        inc_fixes =>   [ add => 1 ],
        dec_fixes =>   [ sub => 1 ],
        add_fixes => 'add',
        flush_fixes => [ mul => 0 ],
    }
);

# Some idea for improvement

# suggest => 'foo' or '$bar foo'
# creates a method analog to next_id (or next_id but I need to change
# run_user_command) that suggest the next id as foo_<nb> where
# nb is incremented each time, or compute the passed formula
# and performs the same

my @common_int_params = qw/min_index max_index max_nb auto_create_ids/;
has \@common_int_params => ( is => 'ro', isa => 'Maybe[Int]' );

my @common_hash_params = qw/default_with_init/;
has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' );

my @common_list_params = qw/allow_keys default_keys auto_create_keys/;
has \@common_list_params => (
    is => 'ro',
    isa => 'KeyArray',
    coerce => 1,
    default => sub { []; }
);

my @common_str_params = qw/allow_keys_from allow_keys_matching follow_keys_from
    migrate_keys_from migrate_values_from
    duplicates warn_if_key_match warn_unless_key_match/;
has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' );

my @common_params =
    ( @common_int_params, @common_str_params, @common_list_params, @common_hash_params );
my @allowed_warp_params = ( @common_params, qw/level convert/ );

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 ), @_ );
};

has [qw/backup cargo/] => ( is => 'ro', isa => 'HashRef', required => 1 );
has warp => ( is => 'ro', isa => 'Maybe[HashRef]' );
has [qw/morph/] => ( is => 'ro', isa => 'Bool', default => 0 );
has content_warning_list => ( is => 'rw', isa => 'ArrayRef', default => sub { []; } );
has [qw/cargo_class max_index index_class index_type/] =>
    ( is => 'rw', isa => 'Maybe[Str]' );

has config_model => (
    is       => 'ro',
    isa      => 'Config::Model',
    weak_ref => 1,
    lazy     => 1,
    builder  => '_config_model'
);

sub _config_model {
    my $self = shift;
    return $self->instance->config_model;
}

sub config_class_name {
    my $self = shift;
    return $self->cargo->{config_class_name};
}

sub BUILD {
    my $self = shift;

    croak "Missing cargo->type parameter for element " . $self->{element_name} || 'unknown'
        unless defined $self->cargo->{type};

    if ( $self->cargo->{type} eq 'node' and not $self->cargo->{config_class_name} ) {
        croak "Missing cargo->config_class_name parameter for element "
        . $self->element_name || 'unknown';
    }

    if ( $self->{cargo}{type} eq 'hash' or $self->{cargo}{type} eq 'list' ) {
        die "$self->{element_name}: using $self->{cargo}{type} will probably not work";
    }

    $self->set_properties();

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

    return $self;
}

# this method can be called by the warp mechanism to alter (warp) the
# feature of the Id object.
sub set_properties ($self, @args) {
    # mega cleanup
    for ( @allowed_warp_params ) { delete $self->{$_}; }

    my %args = ( %{ $self->{backup} }, @args );

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

    $logger->trace( $self->name, " set_properties called with @args" );

    for ( @common_params ) {
        $self->{$_} = delete $args{$_} if defined $args{$_};
    }

    $self->set_convert( \%args ) if defined $args{convert};

    $self-> clear_warpable_check_content;
    for ( $self-> get_all_content_checks ) {
        $self-> add_warpable_check_content($_);
    }
    for ( qw/duplicates/ ) {
        my $method = "check_$_";
        my $weak_self = $self;
        weaken($weak_self); # weaken reference loop ($self - check_content - closure - self)
        $self-> add_check_content( sub { $weak_self->$method(@_);} ) if  $self->{$_};
    }

    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "Undefined index_type"
    ) unless defined $self->{index_type};

    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "Unexpected index_type $self->{index_type}"
        )
        unless ( $self->{index_type} eq 'integer'
        or $self->{index_type} eq 'string' );

    my @current_idx = $self->_fetch_all_indexes();
    if (@current_idx) {
        my $first_idx = shift @current_idx;
        my $last_idx  = pop @current_idx;

        foreach my $idx ( ( $first_idx, $last_idx ) ) {
            my $ok = $self->check_idx($first_idx);
            next if $ok;

            # here a user input may trigger an exception even if fetch
            # or set value check is disabled. That's mostly because,
            # we cannot enforce more strict settings without random
            # deletion of data. For instance, if a hash contains 5
            # items and the max_nb of items is reduced to 3. Which 2
            # items should we remove ?

            # Since we cannot choose, we must raise an exception in
            # all cases.
            Config::Model::Exception::WrongValue->throw(
                error => "Error while setting id property:"
                    . join( "\n\t", @{ $self->{idx_error_list} } ),
                object => $self
            );
        }
    }

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

    return $self->{cargo}{$what};
}

# internal, does a grab with improved error message
sub safe_typed_grab ($self, %args) {
    my $param = $args{param} || croak "safe_typed_grab: missing param";

    my $res = eval {
        $self->grab(
            step  => $self->{$param},
            type  => $self->get_type,
            check => $args{check} || 'yes',
        );
    };

    if ($@) {
        my $e = $@;
        my $msg = $e ? $e->full_message : '';
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "'$param' parameter: " . $msg
        );
    }

    return $res;
}

sub get_default_keys {
    my $self = shift;

    if ( $self->{follow_keys_from} ) {
        my $followed = $self->safe_typed_grab( param => 'follow_keys_from' );
        my @res = $followed->fetch_all_indexes;
        return wantarray ? @res : \@res;
    }

    my @res;

    push @res, @{ $self->{default_keys} }
        if defined $self->{default_keys};

    push @res, keys %{ $self->{default_with_init} }
        if defined $self->{default_with_init};

    return wantarray ? @res : \@res;
}

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

# internal. Handle model declaration arguments
sub handle_args ($self, %args) {
    my $warp_info = delete $args{warp};

    for (qw/index_class index_type morph ordered/) {
        $self->{$_} = delete $args{$_} if defined $args{$_};
    }

    $self->{backup} = dclone( \%args );

    $self->set_properties(%args) if defined $self->{index_type};

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

    return $self;
}

sub apply_fixes {
    my $self = shift;
    $fix_logger->trace( $self->location . ": apply_fixes called" );

    $self->deep_check( fix => 1, logger => $fix_logger );
    return;
}

my %check_idx_dispatch =
    map { ( $_ => 'check_' . $_ ); }
    qw/follow_keys_from allow_keys allow_keys_from allow_keys_matching
    warn_if_key_match warn_unless_key_match/;

my %mode_move = (
    layered => { preset => 1, normal => 1 },
    preset  => { normal => 1 },
    normal  => {},
);

around notify_change => sub ($orig, $self, %args) {
    if ($change_logger->is_trace) {
        my @a = map { ( $_ => $args{$_} // '<undef>' ); } sort keys %args;
        $change_logger->trace( "called for ", $self->name, " from ", join( ' ', caller ),
        " with ", join( ' ', @a ) );
    }

    # $idx may be undef if $self has changed, not necessarily its content
    my $idx = $args{index};
    if ( defined $idx ) {

        # use $idx to trigger move from layered->preset->normal
        my $imode = $self->instance->get_data_mode;
        my $old_mode = $self->get_data_mode($idx) || 'normal';
        $self->set_data_mode( $idx, $imode ) if $mode_move{$old_mode}{$imode};
    }

    return if $self->instance->initial_load and not $args{really};

    $self-> needs_content_check(1);
    $self->$orig(%args);
    return;
};

# the number of checks is becoming confusing. We have
# - check_idx to check whether an index is fine. This is called when creating
#   a new index