view release on metacpan or  search on metacpan

lib/Config/Model/ValueComputer.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::ValueComputer 2.162;

use Mouse;
use MouseX::StrictConstructor;

# use Scalar::Util qw(weaken) ;
use Carp;
use Parse::RecDescent 1.90.0;
use Data::Dumper ();
use Log::Log4perl qw(get_logger :levels);

use vars qw($compute_grammar $compute_parser);

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

my $logger = get_logger("ValueComputer");

# allow_override is intercepted and handled by Value object

has formula    => ( is => 'ro', isa => 'Str', required => 1 );
has value_type => ( is => 'ro', isa => 'Str', required => 1 );

# value_object is mostly used for error messages
has value_object => (
    is => 'ro',
    isa => 'Config::Model::AnyThing',
    required => 1,
    weak_ref => 1,
    handles => [qw/grab grab_value location index element/],
);

has variables => ( is => 'ro', isa => 'HashRef', default => sub { {} } );
has replace   => ( is => 'ro', isa => 'HashRef', default => sub { {} } );
has [qw/use_eval allow_override use_as_upstream_default/] =>
    ( is => 'ro', isa => 'Bool', default => 0 );

has allow_user_override => (
    is   => 'ro',
    isa  => 'Bool',
    lazy => 1,
    builder =>
        sub { my $self = shift; return $self->allow_override || $self->use_as_upstream_default; } );

has need_quote => ( is => 'ro', isa => 'Bool', builder => '_need_quote', lazy => 1 );

sub _need_quote {
    my $self = shift;

    my $need_quote = 0;
    $need_quote = 1 if $self->{use_eval} and $self->{value_type} !~ /(integer|number|boolean)/;
    return $need_quote;
}

has undef_is => ( is => 'ro', isa => 'Maybe[Str]' );

has undef_replacement => (
    is      => 'ro',
    isa     => 'Maybe[Str]',
    builder => '_build_undef_replacement',
    lazy    => 1
);

sub _build_undef_replacement {
    my $self = shift;

    my $sui        = $self->undef_is;

    return defined $sui && $sui eq "''" ? ''
         : defined $sui ? $sui
         :                undef;

}

sub BUILD {
    my $self = shift;

    # create parser if needed
    $compute_parser ||= Parse::RecDescent->new($compute_grammar);

    $logger->trace("called with formula: $self->{formula}");
    # must make a first pass at computation to subsitute index and
    # element values.  leaves $xxx outside of &index or &element untouched
    my $result_r =
        $compute_parser->pre_compute( $self->{formula}, 1, $self->{value_object},
        $self->{variables}, $self->{replace}, 'yes', $self->need_quote, );

    $logger->trace("pre_formula: ". ($result_r ? $$result_r : ' pre_compute failed, using original formula'));
    $self->{pre_formula} = $result_r ? $$result_r : $self->{formula};
    return;
}

sub compute ($self, %args) {
    my $check = $args{check} || 'yes';