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);

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

    # only changes underneath changes the tree. And these changes below triggers
    # their own change notif. So there's no need to call notify_change when transitioning
    # from an undef object into a real object. On the other hand, warping out an object does
    # NOT trigger notify_changes from below. So notify_change must be called
    if ( defined $old_object and $old_config_class_name) {
        my $from = $old_config_class_name ;
        my $to   = $config_class_name     // '<undef>';
        $self->notify_change( note => "warped node from $from to $to" );
    }

    # need to call trigger on all registered objects only after all is setup
    $self->trigger_warp;

    return;
}

sub create_node ($self, $config_class_name) {
    my @args = (
        config_class_name => $config_class_name,
        instance          => $self->{instance},
        element_name      => $self->{element_name},
        parent            => $self->parent,
        container         => $self->container,
    );

    push @args, index_value => $self->index_value if defined $self->index_value;

    return $self->load_node(@args);
}

sub clear ($self) {
    delete $self->{data};
    return;
}

sub load_data ($self, @args) {
    my %args = @args > 1 ? @args : ( data => $args[0] );
    my $data  = $args{data};
    my $check = $self->_check_check( $args{check} );

    if ( ref($data) ne 'HASH' ) {
        Config::Model::Exception::LoadData->throw(
            object     => $self,
            message    => "load_data called with non hash ref arg",
            wrong_data => $data,
        );
    }

    return $self->get_actual_node->load_data(%args);
}

sub is_auto_write_for_type ($self, @args) {
    $self->get_actual_node->is_auto_write_for_type(@args);
    return;
}

# register warper that goes through this path when looking for warp master value
sub register ($self, $warped, $w_idx) {
    $logger->debug( "WarpedNode: " . $self->name, " registered " . $warped->name );

    # weaken only applies to the passed reference, and there's no way
    # to duplicate a weak ref. Only a strong ref is created. See
    #  qw(weaken) module for weaken()
    my @tmp = ( $warped, $w_idx );
    weaken( $tmp[0] );
    push @{ $self->{warp_these_objects} }, \@tmp;
    return;
}

sub trigger_warp ($self) {
    # warp_these_objects is modified by the calls below, so this copy
    # must be done before the loop
    my @list = @{ $self->{warp_these_objects} || [] };

    foreach my $ref (@list) {
        my ( $warped, $warp_index ) = @$ref;
        next unless defined $warped;    # $warped is a weak ref and may vanish

        # pure warp of object
        $logger->debug( "node trigger_warp: from '",
            $self->name, "' warping '", $warped->name, "'" );

        # FIXME: this does not trigger new registration (or removal thereof)...
        $warped->refresh_affected_registrations( $self->location );

        #$warped->refresh_values_from_master ;
        $warped->do_warp;
        $logger->debug( "node trigger_warp: from '",
            $self->name, "' warping '", $warped->name, "' done" );
    }
    return;
}

# FIXME: should we un-register ???

1;

# ABSTRACT: Node that change config class properties

__END__

=pod

=encoding UTF-8

=head1 NAME

Config::Model::WarpedNode - Node that change config class properties

=head1 VERSION

version 2.162

=head1 SYNOPSIS

 use Config::Model;

 my $model = Config::Model->new;
 foreach (qw/X Y/) {
    $model->create_config_class(
        name    => "Class$_",
        element => [ foo => {qw/type leaf value_type string/} ]
    );
 }
 $model->create_config_class(