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.166;

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";
# this requires backup method from Config::Model::AnyThing
with "Config::Model::Role::WarpSubject";

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 'warp'  => ( is => 'rw', isa => 'HashRef', default => sub { {}; });
has 'morph' => ( is => 'ro', isa => 'Bool', default => 0 );

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

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

# used by roles
sub allowed_warp_params {
    return @allowed_warp_params;
}

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.

    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);
    return $self;
}

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

# get_type and get_cargo_type are duplicated from Node, because these
# methods can be called before the actual node is set up.
sub get_type {
    return 'node';
}

sub get_cargo_type {
    return 'node';
}

# 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 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) {