view release on metacpan or  search on metacpan

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

use v5.20;
use Mouse;

use Carp qw(cluck croak);

use Config::Model::Exception;
use Config::Model::Warper;
use Data::Dumper ();
use Log::Log4perl qw(get_logger :levels);
use Storable qw/dclone/;
use Scalar::Util qw/weaken/;

extends qw/Config::Model::AnyThing/;

with "Config::Model::Role::NodeLoader";
with "Config::Model::Role::Grab";

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

my $logger = get_logger("Tree::Node::Warped");

# don't authorize to warp 'morph' parameter as it may lead to
# difficult maintenance

# status is not warpable either as an obsolete parameter must stay
# obsolete

my @allowed_warp_params = qw/config_class_name level gist/;

has 'backup' => ( is => 'rw', isa => 'HashRef', default => sub { {}; } );

has 'warp'  => ( is => 'rw', isa => 'HashRef', default => sub { {}; });
has 'morph' => ( is => 'ro', isa => 'Bool', default => 0 );

has warper => ( is => 'rw', isa => 'Config::Model::Warper' );

has is_building => (
    is => 'ro',
    isa     => 'Bool',
    traits  => ['Bool'],
    default => 0,
    handles => {
        building  => 'set',
        build_done => 'unset',
    },
);

my @backup_list = @allowed_warp_params;

around BUILDARGS => sub ($orig, $class, %args) {
    my %h     = map { ( $_ => $args{$_} ); } grep { defined $args{$_} } @backup_list;
    return $class->$orig( backup => dclone( \%h ), %args );
};

sub BUILD ($self, $) {
    # WarpedNode registers this object in a Value object (the
    # warper).  When the warper gets a new value, it modifies the
    # WarpedNode according to the data passed by the user.

    $self->building;
    my $warp_info = $self->warp;
    $warp_info->{follow} //= {};
    $warp_info->{rules}  //= [];
    my $w = Config::Model::Warper->new(
        warped_object => $self,
        %$warp_info,
        allowed       => \@allowed_warp_params
    );

    $self->warper($w);
    $self->build_done;
    return $self;
}

sub config_model ($self) {
    return $self->parent->config_model;
}

# Forward selected methods (See man perltootc)
foreach my $method (
    qw/fetch_element config_class_name copy_from get_element_name
    get_info fetch_gist has_element is_element_available element_type load
    fetch_element_value get_type get_cargo_type dump_tree needs_save
    describe get_help get_help_as_text children get set accept_regexp/
    ) {
    # to register new methods in package
    no strict "refs"; ## no critic TestingAndDebugging::ProhibitNoStrict

    *$method = sub ($self,@args) {
        if ($self->check) {
            return $self->{data}->$method(@args);
        }

        # return undef if no class was warped in
        return ;
    };
}

sub name ($self) {
    return $self->location;
}

sub is_accessible ($self) {
    return defined $self->{data} ? 1 : 0;
}

sub get_actual_node ($self) {
    $self->check;
    return $self->{data};    # might be undef
}

sub check ($self, $check = 'yes') {
    # must croak if element is not available
    if ( not defined $self->{data} ) {

        # a node can be retrieved either for a store operation or for
        # a fetch.
        if ( $check eq 'yes' and not $self->building) {
            Config::Model::Exception::User->throw(
                object  => $self,
                message => "Object '$self->{element_name}' is not accessible.\n\t"
                    . $self->warp_error
            );
        }
        else {
            return 0;
        }
    }
    return 1;
}

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

    # mega cleanup
    foreach my $awp (@allowed_warp_params) {
        delete $self->{$awp}
    }

    $logger->trace( $self->name . " set_properties called with ",
        Data::Dumper->Dump( [ \%args ], ['set_properties_args'] ) );

    my $config_class_name = delete $args{config_class_name};
    my $node_class = delete $args{class} || 'Config::Model::Node';

    my @prop_args = ( qw/property level element/, $self->element_name );

    my $original_level = $self->config_model->get_element_property(
        class => $self->parent->config_class_name,
        @prop_args,
    );

    my $next_level =
          defined $args{level}       ? $args{level}
        : defined $config_class_name ? $original_level
        :                              'hidden';

    $self->parent->set_element_property( @prop_args, value => $next_level )
        unless defined $self->index_value;

    unless ( defined $config_class_name ) {
        $self->clear;
        return;
    }

    my @class_args;
    ( $config_class_name, @class_args ) = @$config_class_name
        if ref $config_class_name;

    # check if some action is needed (ie. create or morph node)
    return
        if defined $self->{config_class_name}
        and $self->{config_class_name} eq $config_class_name;

    my $old_object            = $self->{data};
    my $old_config_class_name = $self->{config_class_name};

    # create a new object from scratch
    my $new_object = $self->create_node( $config_class_name, @class_args );

    $self->{config_class_name} = $config_class_name;
    $self->{data}              = $new_object;

    if ( defined $old_object and $self->{morph} ) {

        # there an old object that we need to translate
        $logger->debug( "WarpedNode: morphing ", $old_object->name, " to ", $new_object->name )
            if $logger->is_debug;

        $new_object->copy_from( from => $old_object, check => 'skip' );
    }

    # bringing a new object does not really modify the content of the config tree.