has
'follow'
=> (
is
=>
'ro'
,
isa
=>
'HashRef[Str]'
,
required
=> 1 );
has
'rules'
=> (
is
=>
'ro'
,
isa
=>
'ArrayRef'
,
required
=> 1 );
has
'warped_object'
=> (
is
=>
'ro'
,
isa
=>
'Config::Model::AnyThing'
,
handles
=> [
'needs_check'
],
weak_ref
=> 1,
required
=> 1
);
has
'_values'
=> (
traits
=> [
'Hash'
],
is
=>
'ro'
,
isa
=>
'HashRef[HashRef | Str | Undef ]'
,
default
=>
sub
{ {} },
handles
=> {
_set_value
=>
'set'
,
_get_value
=>
'get'
,
_value_keys
=>
'keys'
,
},
);
sub
_get_value_gist {
my
$self
=
shift
;
my
$warper_name
=
shift
;
my
$item
=
$self
->_get_value(
$warper_name
);
return
ref
(
$item
) eq
'HASH'
?
join
(
','
,
each
%$item
) :
$item
;
}
has
[
qw/ _computed_masters _warped_nodes _registered_values/
] => (
is
=>
'rw'
,
isa
=>
'HashRef'
,
init_arg
=>
undef
,
default
=>
sub
{ {} },
);
has
allowed
=> (
is
=>
'rw'
,
isa
=>
'ArrayRef'
);
has
morph
=> (
is
=>
'ro'
,
isa
=>
'Bool'
);
my
$logger
= get_logger(
"Warper"
);
sub
BUILD {
my
$self
=
shift
;
$logger
->trace(
"Warper new: created for "
.
$self
->name );
$self
->check_warp_args;
$self
->register_to_all_warp_masters;
$self
->refresh_values_from_master;
$self
->do_warp;
}
sub
register_to_all_warp_masters {
my
$self
=
shift
;
my
$follow
=
$self
->follow;
foreach
my
$warper_name
(
keys
%$follow
) {
$self
->register_to_one_warp_master(
$warper_name
);
}
}
sub
register_to_one_warp_master {
my
$self
=
shift
;
my
$warper_name
=
shift
||
die
"register_to_one_warp_master: missing warper_name"
;
my
$follow
=
$self
->follow;
my
$warper_path
=
$follow
->{
$warper_name
};
$logger
->debug(
"Warper register_to_one_warp_master: '"
,
$self
->name,
"' follows '$warper_name'"
);
my
@command
= (
$warper_path
);
my
$warper
;
my
$warped_node
;
my
$obj
=
$self
->warped_object;
my
$reg_values
=
$self
->_registered_values;
return
if
defined
$reg_values
->{
$warper_name
};
while
(
@command
) {
(
$obj
,
@command
) =
$obj
->grab(
step
=> \
@command
,
mode
=>
'step_by_step'
,
grab_non_available
=> 1,
);
if
( not
defined
$obj
) {
$logger
->debug(
"Warper register_to_one_warp_master: aborted steps. Left '@command'"
);
last
;
}
my
$obj_loc
=
$obj
->location;
$logger
->debug(
"Warper register_to_one_warp_master: step to master $obj_loc"
);
if
(
$obj
->isa(
'Config::Model::Value'
) or
$obj
->isa(
'Config::Model::CheckList'
)) {
$warper
=
$obj
;
if
(
defined
$warped_node
) {
$self
->_warped_nodes->{
$warped_node
}{
$warper_name
} =
$obj
;
}
last
;
}
if
(
$obj
->isa(
'Config::Model::WarpedNode'
) ) {
$logger
->debug(
"Warper register_to_one_warp_master: register to warped_node $obj_loc"
);
if
(
defined
$warped_node
) {
$self
->_warped_nodes->{
$warped_node
}{
$warper_name
} =
$obj
;
}
$warped_node
=
$obj_loc
;
$obj
->register(
$self
,
$warper_name
);
}
}
if
(
defined
$warper
and
scalar
@command
) {
Config::Model::Exception::Model->throw(
object
=>
$self
->warped_object,
error
=>
"Some steps are left (@command) from warper path $warper_path"
,
);
}
$logger
->debug(
"Warper register_to_one_warp_master:"
,
$self
->name,
" is warped by $warper_name => '$warper_path' location in tree is: '"
,
defined
$warper
?
$warper
->name :
'unknown'
,
"'"
);
return
unless
defined
$warper
;
Config::Model::Exception::Model->throw(
object
=>
$self
->warped_object,
error
=>
"warper $warper_name => '$warper_path' is not a leaf"
)
unless
$warper
->isa(
'Config::Model::Value'
) or
$obj
->isa(
'Config::Model::CheckList'
);
my
$type
=
$warper
->register(
$self
,
$warper_name
);
$reg_values
->{
$warper_name
} =
$warper
;
if
(
$type
eq
'computed'
) {
$self
->_computed_masters->{
$warper_name
} =
$warper
;
}
}
sub
refresh_affected_registrations {
my
(
$self
,
$warped_node_location
) =
@_
;
my
$wnref
=
$self
->_warped_nodes;
$logger
->debug(
"Warper refresh_affected_registrations: called on"
,
$self
->name,
" from $warped_node_location'"
);
my
$ref
=
delete
$wnref
->{
$warped_node_location
};
foreach
my
$warper_name
(
keys
%$ref
) {
$logger
->debug(
"Warper refresh_affected_registrations: "
,
$self
->name,
" unregisters from $warper_name'"
);
delete
$self
->_registered_values->{
$warper_name
};
$ref
->{
$warper_name
}->unregister(
$self
->name );
}
$self
->register_to_all_warp_masters;
}
sub
refresh_values_from_master {
my
$self
=
shift
;
my
$follow
=
$self
->follow;
foreach
my
$warper_name
(
keys
%$follow
) {
my
$warper_path
=
$follow
->{
$warper_name
};
$logger
->debug(
"Warper trigger: "
,
$self
->name,
" following $warper_name"
);
my
$warper
=
$self
->warped_object->grab(
step
=>
$warper_path
,
mode
=>
'loose'
,
);
if
(
defined
$warper
and
$warper
->get_type eq
'leaf'
) {
my
$warper_value
=
$warper
->fetch(
'allow_undef'
);
my
$str
=
$warper_value
//
'<undef>'
;
$logger
->debug(
"Warper: '$warper_name' value is: '$str'"
);
$self
->_set_value(
$warper_name
=>
$warper_value
);
}
elsif
(
defined
$warper
and
$warper
->get_type eq
'check_list'
) {
if
(
$logger
->is_debug) {
my
$warper_value
=
$warper
->fetch();
$logger
->debug(
"Warper: '$warper_name' checked values are: '$warper_value'"
);
}
$self
->_set_value(
$warper_name
=>
scalar
$warper
->get_checked_list_as_hash() );
}
elsif
(
defined
$warper
) {
Config::Model::Exception::Model->throw(
error
=>
"warp error: warp 'follow' parameter "
.
"does not point to a leaf element"
,
object
=>
$self
->warped_object
);
}
else
{
$self
->_set_value(
$warper_name
,
''
);
$logger
->debug(
"Warper: '$warper_name' is not available"
);
}
}
}
sub
name {
my
$self
=
shift
;
return
"Warper of "
.
$self
->warped_object->name;
}
sub
warp_them {
my
$self
=
shift
;
my
$value
=
@_
?
$_
[0]
:
$self
->fetch_no_check;
foreach
my
$ref
( @{
$self
->{warp_these_objects} } ) {
my
(
$warped
,
$warp_index
) =
@$ref
;
next
unless
defined
$warped
;
$logger
->debug(
"Warper "
,
$self
->name,
" warp_them: (value "
,
(
defined
$value
?
$value
:
'undefined'
),
") warping '"
,
$warped
->name,
"'"
);
$warped
->warp(
$value
,
$warp_index
);
}
}
sub
check_warp_args {
my
$self
=
shift
;
my
$rules_ref
=
$self
->rules;
my
@rules
=
ref
$rules_ref
eq
'HASH'
?
%$rules_ref
:
ref
$rules_ref
eq
'ARRAY'
?
@$rules_ref
: Config::Model::Exception::Model->throw(
error
=>
"warp error: warp 'rules' parameter "
.
"is not a ref ($rules_ref)"
,
object
=>
$self
->warped_object
);
my
$allowed
=
$self
->allowed;
for
(
my
$r_idx
= 0 ;
$r_idx
<
$#rules
;
$r_idx
+= 2 ) {
my
$key_set
=
$rules
[
$r_idx
];
my
@keys
=
ref
(
$key_set
) ?
@$key_set
: (
$key_set
);
my
$v
=
$rules
[
$r_idx
+ 1 ];
Config::Model::Exception::Model->throw(
object
=>
$self
->warped_object,
error
=>
"rules value for @keys is not a hash ref ($v)"
)
unless
ref
(
$v
) eq
'HASH'
;
foreach
my
$pkey
(
keys
%$v
) {
Config::Model::Exception::Model->throw(
object
=>
$self
->warped_object,
error
=>
"Warp rules error for '@keys': '$pkey' "
.
"parameter is not allowed, "
.
"expected '"
.
join
(
"' or '"
,
@$allowed
) .
"'"
)
unless
any {
$pkey
eq
$_
}
@$allowed
;
}
}
}
sub
_dclone_key {
return
map
{
ref
$_
? [
@$_
] :
$_
}
@_
;
}
sub
set_parent_element_property {
my
(
$self
,
$arg_ref
) =
@_
;
my
$warped_object
=
$self
->warped_object;
my
@properties
=
qw/level/
;
if
(
defined
$warped_object
->index_value ) {
$logger
->debug(
"Warper set_parent_element_property: called on hash or list, aborted"
);
return
;
}
my
$parent
=
$warped_object
->parent;
my
$elt_name
=
$warped_object
->element_name;
foreach
my
$property_name
(
@properties
) {
my
$v
=
$arg_ref
->{
$property_name
};
if
(
defined
$v
) {
$logger
->debug(
"Warper set_parent_element_property: set '"
,
$parent
->name,
" $elt_name' $property_name with $v"
);
$parent
->set_element_property(
property
=>
$property_name
,
element
=>
$elt_name
,
value
=>
$v
,
);
}
else
{
$logger
->debug(
"Warper set_parent_element_property: reset $property_name"
);
$parent
->reset_element_property(
property
=>
$property_name
,
element
=>
$elt_name
,
);
}
}
}
sub
trigger {
my
$self
=
shift
;
my
%old_value_set
= %{
$self
->_values };
if
(
@_
) {
my
(
$value
,
$warp_name
) =
@_
;
$logger
->debug(
"Warper: trigger called on "
,
$self
->name,
" with value '"
,
defined
$value
?
$value
:
'<undef>'
,
"' name $warp_name"
);
$self
->_set_value(
$warp_name
=>
$value
||
''
);
}
my
$cm
=
$self
->_computed_masters;
foreach
my
$name
(
keys
%$cm
) {
$self
->_set_value(
$name
=>
$cm
->{
$name
}->fetch );
}
my
$same
= 1;
foreach
my
$name
(
$self
->_value_keys ) {
my
$old
=
$old_value_set
{
$name
};
my
$new
=
$self
->_get_value_gist(
$name
);
$same
= 0
if
(
$old
? 1 : 0 xor
$new
? 1 : 0 )
or (
$old
and
$new
and
$new
ne
$old
);
}
if
(
$same
) {
no
warnings
"uninitialized"
;
if
(
$logger
->is_debug ) {
$logger
->debug(
"Warper: warp skipped because no change in value set "
,
"(old: '"
,
join
(
"' '"
,
%old_value_set
),
"' new: '"
,
join
(
"' '"
, %{
$self
->_values() } ),
"')"
);
}
return
;
}
$self
->do_warp;
}
sub
compute_bool {
my
$self
=
shift
;
my
$expr
=
shift
;
$logger
->trace(
"Warper compute_bool: called for '$expr'"
);
$logger
->debug(
"Warper compute_bool: data:\n"
,
Data::Dumper->Dump( [
$self
->_values ], [
'data'
] ) );
$expr
=~ s/(\$\w+)\.is_set\(([&$"
'\w]+)\)/$1.'
->{
'.$2.'
}'/eg;
$expr
=~ s/&(\w+)/\
$warped_obj
->$1/g;
my
@init_code
;
my
%eval_data
;
foreach
my
$warper_name
(
$self
->_value_keys ) {
$eval_data
{
$warper_name
} =
$self
->_get_value(
$warper_name
) ;
push
@init_code
,
"my \$$warper_name = \$eval_data{'$warper_name'} ;"
;
}
my
$perl_code
=
join
(
"\n"
,
@init_code
,
$expr
);
$logger
->trace(
"Warper compute_bool: eval code '$perl_code'"
);
my
$ret
;
{
my
$warped_obj
=
$self
->warped_object ;
no
warnings
"uninitialized"
;
$ret
=
eval
(
$perl_code
);
}
if
($@) {
Config::Model::Exception::Model->throw(
object
=>
$self
->warped_object,
error
=>
"Warp boolean expression failed:\n$@"
.
"eval'ed code is: \n$perl_code"
);
}
$logger
->debug(
"compute_bool: eval result: "
, (
$ret
?
'true'
:
'false'
) );
return
$ret
;
}
sub
do_warp {
my
$self
=
shift
;
my
$warp_value_set
=
$self
->_values;
my
$rules
= dclone(
$self
->rules );
my
%rule_hash
=
@$rules
;
my
$found_rule
= {};
my
$found_bool
=
''
;
foreach
my
$bool_expr
(
@$rules
) {
next
if
ref
(
$bool_expr
);
my
$res
=
$self
->compute_bool(
$bool_expr
);
next
unless
$res
;
$found_bool
=
$bool_expr
;
$found_rule
=
$rule_hash
{
$bool_expr
} || {};
$logger
->trace(
"do_warp found rule for '$bool_expr':\n"
,
Data::Dumper->Dump( [
$found_rule
], [
'found_rule'
] ) );
last
;
}
if
(
$logger
->is_info ) {
my
@warp_str
=
map
{
defined
$_
?
$_
:
'undef'
}
keys
%$warp_value_set
;
$logger
->info(
"do_warp: warp called from '$found_bool' on '"
,
$self
->warped_object->name,
"' with elements '"
,
join
(
"','"
,
@warp_str
),
"', warp rule is "
,
(
scalar
%$found_rule
?
""
:
'not '
),
"found"
);
}
$logger
->trace(
"do_warp: call set_parent_element_property on '"
,
$self
->name,
"' with "
, Data::Dumper->Dump( [
$found_rule
], ['found_rule'] ) );
$self
->set_parent_element_property(
$found_rule
);
$logger
->debug(
"do_warp: call set_properties on '"
,
$self
->warped_object->name,
"' with "
, Data::Dumper->Dump( [
$found_rule
], ['found_rule'] ) );
eval
{
$self
->warped_object->set_properties(
%$found_rule
); };
if
($@) {
my
@warp_str
=
map
{
defined
$_
?
$_
:
'undef'
}
keys
%$warp_value_set
;
my
$e
= $@;
my
$msg
=
ref
$e
?
$e
->as_string :
$e
;
Config::Model::Exception::Model->throw(
object
=>
$self
->warped_object,
error
=>
"Warp failed when following '"
.
join
(
"','"
,
@warp_str
)
.
"' from \"$found_bool\". Check model rules:\n\t"
.
$msg
);
}
}
sub
warp_error {
my
(
$self
) =
@_
;
return
''
unless
defined
$self
->{warp};
my
$follow
=
$self
->{warp}{follow};
my
@rules
= @{
$self
->{warp}{rules} };
my
@warper_paths
=
ref
(
$follow
) eq
'ARRAY'
?
@$follow
:
ref
(
$follow
) eq
'HASH'
?
values
%$follow
: (
$follow
);
my
$str
=
"You may solve the problem by modifying "
. (
@warper_paths
> 1 ?
"one or more of "
:
''
)
.
"the following configuration parameters:\n"
;
my
$expected_error
=
'Config::Model::Exception::UnavailableElement'
;
foreach
my
$warper_path
(
@warper_paths
) {
my
$warper_value
;
my
$warper
;
eval
{
$warper
=
$self
->get_warper_object(
$warper_path
);
$warper_value
=
$warper
->fetch;
};
my
$e
= $@;
if
(
ref
(
$e
) eq
$expected_error
) {
$str
.=
"\t'$warper_path' which is unavailable\n"
;
next
;
}
$warper_value
=
'undef'
unless
defined
$warper_value
;
my
@choice
=
defined
$warper
->choice ? @{
$warper
->choice }
:
$warper
->{value_type} eq
'boolean'
? ( 0, 1 )
: ();
my
@try
=
sort
grep
{
$_
ne
$warper_value
}
@choice
;
$str
.=
"\t'"
.
$warper
->location .
"': Try "
;
my
$a
=
$warper
->{value_type} =~ /^[aeiou]/ ?
'an'
:
'a'
;
$str
.=
@try
?
"'"
.
join
(
"' or '"
,
@try
) .
"' instead of "
:
"$a $warper->{value_type} value different from "
;
$str
.=
"'$warper_value'\n"
;
if
(
defined
$warper
->{compute} ) {
$str
.=
"\n\tHowever, '"
.
$warper
->name .
"' "
.
$warper
->compute_info .
"\n"
;
}
}
$str
.=
"Warp parameters:\n"
. Data::Dumper->Dump( [
$self
->{warp} ], [
'warp'
] )
if
$logger
->is_debug;
return
$str
;
}
__PACKAGE__->meta->make_immutable;
1;