my
(
$model
,
$trace
) = init_test();
$model
->create_config_class(
name
=>
"RSlave"
,
element
=> [
recursive_slave
=> {
type
=>
'hash'
,
index_type
=>
'string'
,
cargo
=> {
type
=>
'node'
,
config_class_name
=>
'RSlave'
},
},
big_compute
=> {
type
=>
'hash'
,
index_type
=>
'string'
,
cargo
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
compute
=> {
variables
=> {
'm'
=>
'! macro'
,
},
formula
=>
'macro is $m, my idx: &index, '
.
'my element &element, '
.
'upper element &element( - ), '
.
'up idx &index( - )'
,
}
},
},
big_replace
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
compute
=> {
formula
=>
'trad idx $replace{&index(-)}'
,
replace
=> {
l1
=>
'level1'
,
l2
=>
'level2'
} }
},
[
qw/bar foo foo2/
] => {
type
=>
'node'
,
config_class_name
=>
'Slave'
},
macro_replace
=> {
type
=>
'hash'
,
index_type
=>
'string'
,
cargo
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
compute
=> {
formula
=>
'trad macro is $replace{$m}'
,
variables
=> {
'm'
=>
'! macro'
, },
replace
=> {
A
=>
'macroA'
,
B
=>
'macroB'
,
C
=>
'macroC'
},
}
},
}
],
);
$model
->create_config_class(
name
=>
"Slave"
,
'element'
=> [
[
qw/X Y Z/
] => {
type
=>
'leaf'
,
value_type
=>
'enum'
,
choice
=> [
qw/Av Bv Cv/
],
warp
=> {
follow
=>
'- - macro'
,
rules
=> {
A
=> {
default
=>
'Av'
},
B
=> {
default
=>
'Bv'
} } }
},
'recursive_slave'
=> {
type
=>
'hash'
,
index_type
=>
'string'
,
cargo
=> {
type
=>
'node'
,
config_class_name
=>
'RSlave'
,
},
},
W
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
level
=>
'hidden'
,
warp
=> {
follow
=>
'- - macro'
,
'rules'
=> {
A
=> {
default
=>
'Av'
,
level
=>
'normal'
,
choice
=> [
qw/Av Bv Cv/
],
},
B
=> {
default
=>
'Bv'
,
level
=>
'normal'
,
choice
=> [
qw/Av Bv Cv/
] } }
},
},
Comp
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
compute
=> {
formula
=>
'macro is $m'
,
variables
=> {
'm'
=>
'- - macro'
},
},
},
warped_by_location
=> {
type
=>
'leaf'
,
value_type
=>
'uniline'
,
default
=>
'slaved'
,
warp
=> {
rules
=> [
'&location =~ /recursive/'
, {
'default'
=>
'rslaved'
} ]
},
},
] );
$model
->create_config_class(
name
=>
"Master"
,
element
=> [
get_element
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
choice
=> [
qw/m_value_element compute_element/
]
},
where_is_element
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
choice
=> [
qw/get_element/
]
},
macro
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
mandatory
=> 1,
choice
=> [
qw/A B C D/
]
},
m_value_out
=> {
type
=>
'leaf'
,
value_type
=>
'uniline'
,
warp
=> {
follow
=>
'- macro'
,
'rules'
=> [
"B"
=> {
level
=>
'hidden'
,
},
] }
},
m2_value_out
=> {
type
=>
'leaf'
,
value_type
=>
'uniline'
,
warp
=> {
follow
=> {
m
=>
'- macro'
,
m2
=>
'- macro2'
},
rules
=> [
'$m eq "A" or $m2 eq "A"'
=> {
level
=>
'hidden'
, }, ] }
},
macro2
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
level
=>
'hidden'
,
warp
=> {
follow
=>
'- macro'
,
'rules'
=> [
"B"
=> {
level
=>
'normal'
,
choice
=> [
qw/A B C D/
]
},
] }
},
'm_value'
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
level
=>
'hidden'
,
'warp'
=> {
follow
=> {
m
=>
'- macro'
},
'rules'
=> [
'$m eq "A" or $m eq "D"'
=> {
choice
=> [
qw/Av Bv/
],
level
=>
'normal'
,
help
=> {
Av
=>
'Av help'
},
},
'$m eq "B"'
=> {
choice
=> [
qw/Bv Cv/
],
level
=>
'normal'
,
help
=> {
Bv
=>
'Bv help'
},
},
'$m eq "C"'
=> {
choice
=> [
qw/Cv/
],
level
=>
'normal'
,
help
=> {
Cv
=>
'Cv help'
},
} ] }
},
'm_value_old'
=> {
type
=>
'leaf'
,
value_type
=>
'enum'
,
level
=>
'hidden'
,
'warp'
=> {
follow
=>
'- macro'
,
'rules'
=> [
[
qw/A D/
] => {
choice
=> [
qw/Av Bv/
],
level
=>
'normal'
,
help
=> {
Av
=>
'Av help'
},
},
B
=> {
choice
=> [
qw/Bv Cv/
],
level
=>
'normal'
,
help
=> {
Bv
=>
'Bv help'
},
},
C
=> {
choice
=> [
qw/Cv/
],
level
=>
'normal'
,
help
=> {
Cv
=>
'Cv help'
},
} ] }
},
'compute'
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
compute
=> {
formula
=>
'macro is $m, my element is &element'
,
variables
=> {
'm'
=>
'! macro'
},
},
},
'var_path'
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
mandatory
=> 1,
compute
=> {
formula
=>
'get_element is $replace{$s}, indirect value is \'$v\''
,
variables
=> {
's'
=>
'! $where'
,
where
=>
'! where_is_element'
,
v
=>
'! $replace{$s}'
,
},
replace
=> {
qw/m_value_element m_value compute_element compute/
} }
},
'class'
=> {
type
=>
'hash'
,
index_type
=>
'string'
,
cargo
=> {
type
=>
'leaf'
,
value_type
=>
'string'
},
},
'warped_out_ref'
=> {
type
=>
'leaf'
,
refer_to
=>
'! class'
,
value_type
=>
'reference'
,
level
=>
'hidden'
,
warp
=> {
follow
=> {
m
=>
'- macro'
,
m2
=>
'- macro2'
},
rules
=> [
'$m eq "A" or $m2 eq "A"'
=> {
level
=>
'normal'
, }, ]
}
},
[
qw/bar foo foo2/
] => {
type
=>
'node'
,
config_class_name
=>
'Slave'
},
'ClientAliveCheck'
,
{
'value_type'
=>
'boolean'
,
'upstream_default'
=>
'0'
,
'type'
=>
'leaf'
,
},
'ClientAliveInterval'
,
{
'value_type'
=>
'integer'
,
'level'
=>
'hidden'
,
'min'
=>
'1'
,
'warp'
=> {
'follow'
=> {
'c_a_check'
=>
'- ClientAliveCheck'
},
'rules'
=> [
'$c_a_check == 1'
, {
'level'
=>
'normal'
} ]
},
'type'
=>
'leaf'
},
'compute_simple'
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
compute
=> {
formula
=>
'my element is &element'
,
},
},
warped_from_computed_value
=> {
type
=>
'leaf'
,
value_type
=>
'string'
,
level
=>
'hidden'
,
default
=>
'hello'
,
warp
=> {
follow
=> {
c
=>
'- compute_simple'
},
rules
=> [
'$c =~ /simple/'
=> {
level
=>
'normal'
, }, ]
}
}
] );
my
$inst
=
$model
->instance(
root_class_name
=>
'Master'
,
instance_name
=>
'test1'
);
ok(
$inst
,
"created dummy instance"
);
my
$root
=
$inst
->config_root;
my
$mvo
=
$root
->fetch_element(
'm_value_out'
);
isa_ok(
$mvo
->{warper},
'Config::Model::Warper'
,
"check warper object"
);
my
$macro
=
$root
->fetch_element(
'macro'
);
my
@macro_slaves
= (
'Warper of Master m_value_out'
);
eq_or_diff( [
map
{
$_
->name }
$macro
->get_depend_slave ],
\
@macro_slaves
,
"check m_value_out warper"
);
my
$mvo2
=
$root
->fetch_element(
'm2_value_out'
);
isa_ok(
$mvo2
->{warper},
'Config::Model::Warper'
,
"check warper object"
);
push
@macro_slaves
,
'Warper of Master m2_value_out'
,
'Warper of Master macro2'
;
eq_or_diff(
[
sort
map
{
$_
->name }
$macro
->get_depend_slave ],
[
sort
@macro_slaves
],
"check m_value_out and m2_value_out warper"
);
eq_or_diff(
[
$root
->get_element_name() ],
[
qw'get_element where_is_element macro m_value_out m2_value_out
compute var_path class bar foo foo2 ClientAliveCheck
compute_simple warped_from_computed_value'
],
"Elements of Master"
);
eq_or_diff( [
$model
->get_element_name(
class
=>
'Slave'
,
)
],
[
qw'X Y Z recursive_slave Comp warped_by_location'
],
"Elements of Slave from the model"
);
my
$slave
=
$root
->fetch_element(
'bar'
);
ok(
$slave
,
"Created slave(bar)"
);
eq_or_diff(
[
$slave
->get_element_name() ],
[
qw'X Y Z recursive_slave Comp warped_by_location'
],
"Elements of Slave from the object"
);
throws_ok {
$slave
->fetch_element(
'W'
)->fetch; }
qr/unavailable/
,
"reading slave->W (undef value_type error)"
;
is(
$slave
->fetch_element(
'X'
)->fetch,
undef
,
"reading slave->X (undef)"
);
is(
$macro
->store(
'B'
), 1,
"setting master->macro to B"
);
eq_or_diff(
[
$root
->get_element_name() ],
[
qw'get_element where_is_element macro m2_value_out macro2 m_value
m_value_old compute var_path class bar foo foo2
ClientAliveCheck compute_simple warped_from_computed_value'
],
"Elements of Master when macro = B"
);
is(
$root
->fetch_element(
'macro2'
)->store(
'A'
), 1,
"setting master->macro2 to A"
);
is_deeply(
[
$root
->get_element_name() ],
[
qw'get_element where_is_element macro macro2
m_value m_value_old compute var_path class warped_out_ref bar
foo foo2 ClientAliveCheck compute_simple warped_from_computed_value'
],
"Elements of Master when macro = B macro2 = A"
);
$root
->fetch_element(
'class'
)->fetch_with_id(
'foo'
)->store(
'foo_v'
);
$root
->fetch_element(
'class'
)->fetch_with_id(
'bar'
)->store(
'bar_v'
);
is(
$root
->fetch_element(
'warped_out_ref'
)->store(
'foo'
),
1,
"setting master->warped_out_ref to foo"
);
is(
$root
->fetch_element(
'macro'
)->store(
'A'
), 1,
"setting master->macro to A"
);
foreach
(
qw/X Y Z/
) { is(
$slave
->fetch_element(
$_
)->fetch,
'Av'
,
"reading slave->$_ (Av)"
); }
is(
$root
->fetch_element(
'macro'
)->store(
'C'
), 1,
"setting master->macro to C"
);
is(
$root
->fetch_element(
'm_value'
)->get_help(
'Cv'
),
'Cv help'
,
'test m_value help with macro=C'
);
is(
$slave
->fetch_element(
'X'
)->fetch,
undef
,
"reading slave->X (undef)"
);
$root
->fetch_element(
'macro'
)->store(
'A'
);
is(
$root
->fetch_element(
'm_value'
)->store(
'Av'
), 1,
'test m_value with macro=A'
);
is(
$root
->fetch_element(
'm_value_old'
)->store(
'Av'
), 1,
'test m_value_old with macro=A'
);
is(
$root
->fetch_element(
'm_value'
)->get_help(
'Av'
),
'Av help'
,
'test m_value help with macro=A'
);
is(
$root
->fetch_element(
'm_value'
)->get_help(
'Cv'
),
undef
,
'test m_value help with macro=A'
);
$root
->fetch_element(
'macro'
)->store(
'D'
);
is(
$root
->fetch_element(
'warped_from_computed_value'
)->fetch,
'hello'
,
"check 'warped_from_computed_value"
);
is(
$root
->fetch_element(
'm_value'
)->fetch,
'Av'
,
'test m_value with macro=D'
);
is(
$root
->fetch_element(
'm_value_old'
)->fetch,
'Av'
,
'test m_value_old with macro=D'
);
$root
->fetch_element(
'macro'
)->store(
'A'
);
is_deeply(
[
$slave
->get_element_name() ],
[
qw/X Y Z recursive_slave W Comp warped_by_location/
],
"Slave elements from the object (W pops in when macro is set to A)"
);
$root
->fetch_element(
'macro'
)->store(
'B'
);
is_deeply(
[
$slave
->get_element_name() ],
[
qw/X Y Z recursive_slave W Comp warped_by_location/
],
"Slave elements from the object"
);
foreach
(
qw/X Y Z/
) { is(
$slave
->fetch_element(
$_
)->fetch,
'Bv'
,
"reading slave->$_ (Bv)"
); }
is(
$slave
->fetch_element(
'Y'
)->store(
'Cv'
), 1,
'Set slave->Y to Cv'
);
$root
->fetch_element(
'macro'
)->store(
'C'
);
is(
$slave
->is_element_available(
name
=>
'W'
),
0,
" test W is not available"
);
$root
->fetch_element(
'macro'
)->store(
'B'
);
is(
$slave
->is_element_available(
name
=>
'W'
),
1,
" test W is available"
);
$root
->fetch_element(
'macro'
)->store(
'C'
);
foreach
(
qw/X Z/
) { is(
$slave
->fetch_element(
$_
)->fetch,
undef
,
"reading slave->$_ (undef)"
); }
is(
$slave
->fetch_element(
'Y'
)->fetch,
'Cv'
,
"reading slave->Y (Cv)"
);
is(
$slave
->fetch_element(
'Comp'
)->fetch,
'macro is C'
,
"reading slave->Comp"
);
is(
$root
->fetch_element(
'm_value'
)->store(
'Cv'
), 1,
'set m_value to Cv'
);
my
$rslave1
=
$slave
->fetch_element(
'recursive_slave'
)->fetch_with_id(
'l1'
);
my
$rslave2
=
$rslave1
->fetch_element(
'recursive_slave'
)->fetch_with_id(
'l2'
);
my
$big_compute_obj
=
$rslave2
->fetch_element(
'big_compute'
)->fetch_with_id(
'b1'
);
isa_ok(
$big_compute_obj
,
'Config::Model::Value'
,
'Created new big compute object'
);
my
$bc_val
=
$rslave2
->fetch_element(
'big_compute'
)->fetch_with_id(
"test_1"
)->fetch;
is(
$bc_val
,
'macro is C, my idx: test_1, my element big_compute, upper element recursive_slave, up idx l2'
,
'reading slave->big_compute(test1)'
);
is(
$big_compute_obj
->fetch,
'macro is C, my idx: b1, my element big_compute, upper element recursive_slave, up idx l2'
,
'reading slave->big_compute(b1)'
);
is(
$rslave1
->fetch_element(
'big_replace'
)->fetch(),
'trad idx level1'
,
'reading rslave1->big_replace(br1)'
);
is(
$rslave2
->fetch_element(
'big_replace'
)->fetch(),
'trad idx level2'
,
'reading rslave2->big_replace(br1)'
);
is(
$rslave1
->fetch_element(
'macro_replace'
)->fetch_with_id(
'br1'
)->fetch,
'trad macro is macroC'
,
'reading rslave1->macro_replace(br1)'
);
is(
$rslave2
->fetch_element(
'macro_replace'
)->fetch_with_id(
'br1'
)->fetch,
'trad macro is macroC'
,
'reading rslave2->macro_replace(br1)'
);
is(
$root
->fetch_element(
'compute'
)->fetch(),
'macro is C, my element is compute'
,
'reading root->compute'
);
my
@masters
=
$root
->fetch_element(
'macro'
)->get_depend_slave();
my
@names
=
sort
map
{
$_
->name }
@masters
;
print
"macro controls:\n\t"
,
join
(
"\n\t"
,
@names
),
"\n"
if
$trace
;
is(
scalar
@masters
, 16,
'reading macro slaves'
);
eq_or_diff(
\
@names
,
[
'Master compute'
,
'Warper of Master m2_value_out'
,
'Warper of Master m_value'
,
'Warper of Master m_value_old'
,
'Warper of Master m_value_out'
,
'Warper of Master macro2'
,
'Warper of Master warped_out_ref'
,
'Warper of bar W'
,
'Warper of bar X'
,
'Warper of bar Y'
,
'Warper of bar Z'
,
'bar Comp'
,
'bar recursive_slave:l1 macro_replace:br1'
,
'bar recursive_slave:l1 recursive_slave:l2 big_compute:b1'
,
'bar recursive_slave:l1 recursive_slave:l2 big_compute:test_1'
,
'bar recursive_slave:l1 recursive_slave:l2 macro_replace:br1'
,
],
"check names of values using 'macro' element"
);
Config::Model::Exception::Any->Trace(1);
throws_ok {
$root
->fetch_element(
'var_path'
)->fetch; }
qr/'! where_is_element' is undef/
,
'reading var_path while where_is_element variable is undef'
;
$root
->fetch_element(
'where_is_element'
)->store(
'get_element'
);
is(
$root
->fetch_element(
'var_path'
)->fetch(
check
=>
'no'
),
undef
,
'reading var_path while where_is_element is defined'
);
throws_ok {
$root
->fetch_element(
'var_path'
)->fetch; }
qr/Undefined mandatory value/
,
'reading var_path while get_element variable is undef'
;
$root
->fetch_element(
'get_element'
)->store(
'm_value_element'
);
is(
$root
->fetch_element(
'var_path'
)->fetch(),
'get_element is m_value, indirect value is \'Cv\''
,
"reading var_path through m_value element"
);
$root
->fetch_element(
'get_element'
)->store(
'compute_element'
);
is(
$root
->fetch_element(
'var_path'
)->fetch(),
'get_element is compute, indirect value is \'macro is C, my element is compute\''
,
"reading var_path through compute element"
);
$root
->fetch_element(
'ClientAliveCheck'
)->store(0);
throws_ok {
$root
->fetch_element(
'ClientAliveInterval'
)->fetch; }
qr/unavailable element/
,
'reading ClientAliveInterval when ClientAliveCheck is 0'
;
$root
->fetch_element(
'ClientAliveCheck'
)->store(1);
$root
->fetch_element(
'ClientAliveInterval'
)->store(10);
is(
$root
->fetch_element(
'ClientAliveInterval'
)->fetch, 10,
"check ClientAliveInterval"
);
my
%loc_h
= (
qw/bar slaved foo2 slaved/
,
'bar recursive_slave:l1 foo2'
=>
'rslaved'
,
'bar recursive_slave:l1 recursive_slave:l2 foo2'
=>
'rslaved'
);
foreach
my
$k
(
sort
keys
%loc_h
) {
my
$path
=
"$k warped_by_location"
;
is(
$root
->grab_value(
$path
),
$loc_h
{
$k
},
"check &location with $path"
);
}
my
$layered_i
=
$model
->instance(
root_class_name
=>
'Master'
,
instance_name
=>
'test_layered'
);
ok(
$layered_i
,
"created layered instance"
);
my
$l_root
=
$layered_i
->config_root;
$layered_i
->layered_start;
my
$l_macro
=
$l_root
->fetch_element(
'macro'
);
$l_macro
->store(
'D'
);
my
$l_mv
=
$l_root
->fetch_element(
'm_value'
);
$layered_i
->layered_stop;
$l_mv
->store(
'Av'
);
is(
$l_mv
->fetch,
'Av'
,
"test warp in layered mode"
);
memory_cycle_ok(
$model
,
"test memory cycle"
);
done_testing ;