backup results from the CPAN

Config-Model

#
# 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::Value 2.162;

use v5.20;

use strict;
use warnings;

use Mouse;
use Mouse::Util::TypeConstraints;
use MouseX::StrictConstructor;

use Parse::RecDescent 1.90.0;

use Data::Dumper ();
use Config::Model::Exception;
use Config::Model::ValueComputer;
use Config::Model::IdElementReference;
use Config::Model::Warper;
use Config::Model::Value::Update;

use Log::Log4perl qw(get_logger :levels);
use Scalar::Util qw/weaken/;
use Carp;
use Storable qw/dclone/;
use Path::Tiny;
use List::Util qw(any) ;
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";

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

my $logger        = get_logger("Tree::Element::Value");
my $user_logger   = get_logger("User");
my $change_logger = get_logger("Anything::Change");
my $fix_logger    = get_logger("Anything::Fix");

our $nowarning = 0;    # global variable to silence warnings. Only used for tests

enum ValueType => qw/boolean enum uniline string integer number reference file dir/;

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

has [qw/warp compute computed_refer_to backup migrate_from/] =>
    ( is => 'rw', isa => 'Maybe[HashRef]' );

has compute_obj => (
    is      => 'ro',
    isa     => 'Maybe[Config::Model::ValueComputer]',
    builder => '_build_compute_obj',
    lazy    => 1
);

has [qw/write_as/] => ( is => 'rw', isa => 'Maybe[ArrayRef]' );

has [qw/refer_to _data replace_follow/] => ( is => 'rw', isa => 'Maybe[Str]' );

has value_type => ( is => 'rw', isa => 'ValueType' );

my @common_int_params = qw/min max mandatory /;
has \@common_int_params => ( is => 'ro', isa => 'Maybe[Int]' );

my @common_hash_params = qw/replace assert update warn_if_match warn_unless_match warn_if warn_unless help/;
has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' );

has update_obj => (
    is => 'ro',
    isa => 'Undef|Config::Model::Value::Update',
    handles => [qw/get_update_value/],
    lazy => 1,
    builder => sub ($self) {
        if (my $ref = $self->update) {
            return Config::Model::Value::Update->new(%$ref, location => $self->location);
        }
    }
);

my @common_list_params = qw/choice/;
has \@common_list_params => ( is => 'ro', isa => 'Maybe[ArrayRef]' );

my @common_str_params = qw/default upstream_default convert match grammar warn/;
has \@common_str_params => ( is => 'ro', isa => 'Maybe[Str]' );

my @warp_accessible_params =
    ( @common_int_params, @common_str_params, @common_list_params, @common_hash_params );

my @allowed_warp_params = ( @warp_accessible_params, qw/level help/ );
my @backup_list         = ( @allowed_warp_params,    qw/migrate_from/ );

has compute_is_upstream_default =>
    ( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_upstream_default' );

sub _compute_is_upstream_default {
    my $self = shift;
    return 0 unless defined $self->compute;
    return $self->compute_obj->use_as_upstream_default;
}

has compute_is_default =>
    ( is => 'ro', isa => 'Bool', lazy => 1, builder => '_compute_is_default' );

sub _compute_is_default {
    my $self = shift;
    return 0 unless defined $self->compute;
    return !$self->compute_obj->use_as_upstream_default;
}

has error_list => (
    is      => 'ro',
    isa     => 'ArrayRef',
    default => sub { [] },
    traits  => ['Array'],
    handles => {
        add_error    => 'push',
        clear_errors => 'clear',
        has_error    => 'count',
        all_errors   => 'elements',
        is_ok        => 'is_empty'
    } );

sub error_msg  ($self) {
    my $msg = '';
    if ($self->has_error) {
        my @add;
        push @add, $self->compute_obj->compute_info if $self->compute_obj;
        push @add, $self->{_migrate_from}->compute_info if $self->{_migrate_from};
        $msg = join("\n", $self->all_errors, @add);
    }
    return $msg;
}

has warning_list => (
    is      => 'ro',
    isa     => 'ArrayRef',
    default => sub { [] },
    traits  => ['Array'],
    handles => {
        add_warning    => 'push',
        clear_warnings => 'clear',
        warning_msg    => [ join => "\n\t" ],
        has_warning    => 'count',
        has_warnings    => 'count',
        all_warnings   => 'elements',
    } );

# as some information must be backed up even though they are not
# attributes, we cannot move code below in BUILD.
around BUILDARGS => sub ($orig, $class, %args) {
    my %h = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list;
    return $class->$orig( backup => dclone( \%h ), %args );
};

sub BUILD {
    my $self = shift;

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

    # used when self is a warped slave
    if ( my $warp_info = $self->warp ) {
        $self->{warper} = Config::Model::Warper->new(
            warped_object => $self,
            %$warp_info,
            allowed => \@allowed_warp_params
        );
    }

    $self->_init;

    return $self;
}

override 'needs_check' => sub ($self, @args) {
    if ($self->instance->layered) {
        # don't check value and don't store value in layered mode
        return 0;
    }
    elsif (@args) {
        return super();
    }
    else {
        # some items like idElementReference are too complex to propagate
        # a change notification back to the value using them. So an error or
        # warning must always be rechecked.
        return ($self->value_type eq 'reference' or super()) ;
    }
};

around notify_change => sub ($orig, $self, %args) {
    my $check_done = $args{check_done} || 0;

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

    if ($change_logger->is_trace) {
        my @a = map { ( $_ => $args{$_} // '<undef>' ); } sort keys %args;
        $change_logger->trace( "called while needs_check is ",
        $self->needs_check, " for ", $self->name, " with ", join( ' ', @a ) );
    }

    $self->needs_check(1) unless $check_done;
    {
        croak "needless change with $args{new}"
            if defined $args{old}
            and defined $args{new}
            and $args{old} eq $args{new};
    }
    $args{new} = $self->map_write_as( $args{new} );
    $args{old} = $self->map_write_as( $args{old} );
    $self->$orig( %args, value_type => $self->value_type );

    # shake all warped or computed objects that depends on me
    foreach my $s ( $self->get_depend_slave ) {
        $change_logger->debug( "calling needs_check on slave ", $s->name )
            if $change_logger->is_debug;
        $s->needs_check(1);
    }
    return;

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

        eval { qr/$regexp/; };

        if ($@) {
            Config::Model::Exception::Model->throw(
                object => $self,
                error  => "Unvalid $what regexp '$regexp': $@"
            );
        }

        my $v = $h->{$regexp};
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "value of $what regexp '$regexp' is not a hash ref but '$v'"
        ) unless ref $v eq 'HASH';

    }
    return;
}

sub setup_grammar_check {
    my ( $self, $ref ) = @_;

    my $str = $self->{grammar} = delete $ref->{grammar};
    return unless defined $str;
    my $vt = $self->{value_type};

    if ( $vt ne 'uniline' and $vt ne 'string' ) {
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "Can't use match regexp with $vt, " . "expected 'uniline' or 'string'"
        );
    }

    my @lines = split /\n/, $str;
    chomp @lines;
    if ( $lines[0] !~ /^check:/ ) {
        $lines[0] = 'check: ' . $lines[0] . ' /\s*\Z/ ';
    }

    my $actual_grammar = join( "\n", @lines ) . "\n";
    $logger->debug( $self->name, " setup_grammar_check with '$actual_grammar'" );
    eval { $self->{validation_parser} = Parse::RecDescent->new($actual_grammar); };

    if ($@) {
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "Unvalid grammar for '$str': $@"
        );
    }
    return;
}

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

    # merge data passed to the constructor with data passed to set_properties
    my %args = ( %{ $self->backup // {} }, @args );

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

    if ( $logger->is_trace ) {
        $logger->trace( "Leaf '" . $self->name . "' set_properties called with '",
            join( "','", sort keys %args ), "'" );
    }

    if (    defined $args{value_type}
        and $args{value_type} eq 'reference'
        and not defined $self->{refer_to}
        and not defined $self->{computed_refer_to} ) {
        Config::Model::Exception::Model->throw(
            object => $self,
            error  => "Missing 'refer_to' or 'computed_refer_to' "
                . "parameter with 'reference' value_type "
        );
    }

    for (qw/min max mandatory warn replace_follow assert warn_if warn_unless
            write_as/) {
        $self->{$_} = delete $args{$_} if defined $args{$_};
    }

    if ($args{replace}) {
        $self->{replace} = delete $args{replace};
        my $old = $self->_fetch_no_check;
        if (defined $old) {
            my $new = $self->apply_replace($old);
            $self->_store_value($new);
        }
    }

    $self->set_help( \%args );
    $self->set_update( \%args );
    $self->set_value_type( \%args );
    $self->set_default( \%args );
    $self->set_convert( \%args ) if defined $args{convert};
    $self->setup_match_regexp( match => \%args ) if defined $args{match};
    foreach (qw/warn_if_match warn_unless_match/) {
        $self->check_validation_regexp( $_ => \%args ) if defined $args{$_};
    }
    $self->setup_grammar_check( \%args ) if defined $args{grammar};

    # cannot be warped
    $self->set_migrate_from( \%args ) if defined $args{migrate_from};

    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "write_as is allowed only with boolean values"
    ) if defined $self->{write_as} and $self->{value_type} ne 'boolean';

    Config::Model::Exception::Model->throw(
        object => $self,
        error  => "Unexpected parameters: " . join( ' ', each %args ) ) if scalar keys %args;

    if ( $self->has_warped_slaves ) {
        my $value = $self->_fetch_no_check;
        $self->trigger_warp($value);

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

    }
    elsif ( defined $self->{computed_refer_to} ) {
        $self->{ref_object} = Config::Model::IdElementReference->new(
            computed_refer_to => $self->{computed_refer_to},
            config_elt        => $self,
        );

        # refer_to registration is done for all element that are used as
        # variable for complex reference (ie '- $foo' , {foo => '- bar'} )
        $self->register_in_other_value( $self->{computed_refer_to}{variables} );
    }
    else {
        croak "value's submit_to_refer_to: undefined refer_to or computed_refer_to";
    }
    return;
}

sub setup_reference_choice ($self, @args) {
    return $self->setup_enum_choice(@args);
}

sub reference_object {
    my $self = shift;
    return $self->{ref_object};
}

sub built_in {
    carp "warning: built_in sub is deprecated, use upstream_default";
    goto &upstream_default;
}

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

sub get_type {
    return 'leaf';
}

sub get_cargo_type {
    return 'leaf';
}

sub can_store {
    my $self = shift;

    if ( not defined $self->compute ) {
        return 1;
    }
    if ( $self->compute_obj->allow_user_override ) {
        return 1;
    }
    return;
}

sub get_default_choice {
    my $self = shift;
    return @{ $self->{backup}{choice} || [] };
}

sub get_choice {
    my $self = shift;

    # just in case the reference_object has been changed
    if ( defined $self->{refer_to} or defined $self->{computed_refer_to} ) {
        $self->{ref_object}->get_choice_from_referred_to;
    }

    return @{ $self->{choice} || [] };
}

sub get_info {
    my $self = shift;

    my $type       = $self->value_type;
    my @choice     = $type eq 'enum' ? $self->get_choice : ();
    my $choice_str = @choice ? ' (' . join( ',', @choice ) . ')' : '';

    my @items = ( 'type: ' . $self->value_type . $choice_str, );

    my $std = $self->fetch(qw/mode standard check no/);

    if ( defined $self->upstream_default ) {
        push @items, "upstream_default value: " . $self->map_write_as( $self->upstream_default );
    }
    elsif ( defined $std ) {
        push @items, "default value: $std";
    }
    elsif ( defined $self->refer_to ) {
        push @items, "reference to: " . $self->refer_to;
    }
    elsif ( defined $self->computed_refer_to ) {
        push @items, "computed reference to: " . $self->computed_refer_to;
    }

    if ($self->update) {
        push @items, "update value from " . $self->update_obj->get_info;
    }

    my $m = $self->mandatory;
    push @items, "is mandatory: " . ( $m ? 'yes' : 'no' ) if defined $m;

    foreach my $what (qw/min max warn grammar/) {
        my $v = $self->$what();
        push @items, "$what value: $v" if defined $v;
    }

    foreach my $what (qw/warn_if_match warn_unless_match/) {
        my $v = $self->$what();
        foreach my $k ( keys %$v ) {
            push @items, "$what value: $k";
        }
    }

    foreach my $what (qw/write_as/) {
        my $v = $self->$what();
        push @items, "$what: @$v" if defined $v;
    }

( run in 0.634 second using v1.01-cache-2.11-cpan-39bf76dae61 )