1# -*- cperl -*- 2 3use Test::More; 4use Test::Differences; 5use Test::Memory::Cycle; 6use Test::Exception; 7use Config::Model; 8use Config::Model::ValueComputer; 9use Config::Model::Tester::Setup qw/init_test/; 10 11use strict; 12use warnings; 13 14my ($model, $trace) = init_test(); 15 16$model->create_config_class( 17 name => "RSlave", 18 element => [ 19 recursive_slave => { 20 type => 'hash', 21 index_type => 'string', 22 cargo => { 23 type => 'node', 24 config_class_name => 'RSlave' 25 }, 26 }, 27 big_compute => { 28 type => 'hash', 29 index_type => 'string', 30 cargo => { 31 type => 'leaf', 32 value_type => 'string', 33 compute => { 34 variables => { 35 'm' => '! macro', 36 }, 37 formula => 'macro is $m, my idx: &index, ' 38 . 'my element &element, ' 39 . 'upper element &element( - ), ' 40 . 'up idx &index( - )', 41 } 42 }, 43 }, 44 big_replace => { 45 type => 'leaf', 46 value_type => 'string', 47 compute => { 48 formula => 'trad idx $replace{&index(-)}', 49 replace => { 50 l1 => 'level1', 51 l2 => 'level2' 52 } } 53 }, 54 [qw/bar foo foo2/] => { 55 type => 'node', 56 config_class_name => 'Slave' 57 }, 58 macro_replace => { 59 type => 'hash', 60 index_type => 'string', 61 cargo => { 62 type => 'leaf', 63 value_type => 'string', 64 compute => { 65 formula => 'trad macro is $replace{$m}', 66 variables => { 'm' => '! macro', }, 67 replace => { 68 A => 'macroA', 69 B => 'macroB', 70 C => 'macroC' 71 }, 72 } 73 }, 74 } 75 ], 76); 77 78$model->create_config_class( 79 name => "Slave", 80 81 'element' => [ 82 [qw/X Y Z/] => { 83 type => 'leaf', 84 value_type => 'enum', 85 choice => [qw/Av Bv Cv/], 86 warp => { 87 follow => '- - macro', 88 rules => { 89 A => { default => 'Av' }, 90 B => { default => 'Bv' } } } 91 }, 92 'recursive_slave' => { 93 type => 'hash', 94 index_type => 'string', 95 cargo => { 96 type => 'node', 97 config_class_name => 'RSlave', 98 }, 99 }, 100 W => { 101 type => 'leaf', 102 value_type => 'enum', 103 level => 'hidden', 104 warp => { 105 follow => '- - macro', 106 'rules' => { 107 A => { 108 default => 'Av', 109 level => 'normal', 110 choice => [qw/Av Bv Cv/], 111 }, 112 B => { 113 default => 'Bv', 114 level => 'normal', 115 choice => [qw/Av Bv Cv/] } } 116 }, 117 }, 118 Comp => { 119 type => 'leaf', 120 value_type => 'string', 121 compute => { 122 formula => 'macro is $m', 123 variables => { 'm' => '- - macro' }, 124 }, 125 }, 126 warped_by_location => { 127 type => 'leaf', 128 value_type => 'uniline', 129 default => 'slaved', 130 warp => { 131 rules => [ '&location =~ /recursive/', { 'default' => 'rslaved' } ] 132 }, 133 }, 134 ] ); 135 136$model->create_config_class( 137 name => "Master", 138 element => [ 139 get_element => { 140 type => 'leaf', 141 value_type => 'enum', 142 choice => [qw/m_value_element compute_element/] 143 }, 144 where_is_element => { 145 type => 'leaf', 146 value_type => 'enum', 147 choice => [qw/get_element/] 148 }, 149 macro => { 150 type => 'leaf', 151 value_type => 'enum', 152 mandatory => 1, 153 choice => [qw/A B C D/] 154 }, 155 m_value_out => { 156 type => 'leaf', 157 value_type => 'uniline', 158 warp => { 159 follow => '- macro', 160 'rules' => [ 161 "B" => { 162 level => 'hidden', 163 }, 164 ] } 165 }, 166 m2_value_out => { 167 type => 'leaf', 168 value_type => 'uniline', 169 warp => { 170 follow => { m => '- macro', m2 => '- macro2' }, 171 rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'hidden', }, ] } 172 }, 173 macro2 => { 174 type => 'leaf', 175 value_type => 'enum', 176 level => 'hidden', 177 warp => { 178 follow => '- macro', 179 'rules' => [ 180 "B" => { 181 level => 'normal', 182 choice => [qw/A B C D/] 183 }, 184 ] } 185 }, 186 'm_value' => { 187 type => 'leaf', 188 value_type => 'enum', 189 level => 'hidden', 190 'warp' => { 191 follow => { m => '- macro' }, 192 'rules' => [ 193 '$m eq "A" or $m eq "D"' => { 194 choice => [qw/Av Bv/], 195 level => 'normal', 196 help => { Av => 'Av help' }, 197 }, 198 '$m eq "B"' => { 199 choice => [qw/Bv Cv/], 200 level => 'normal', 201 help => { Bv => 'Bv help' }, 202 }, 203 '$m eq "C"' => { 204 choice => [qw/Cv/], 205 level => 'normal', 206 help => { Cv => 'Cv help' }, 207 } ] } 208 }, 209 'm_value_old' => { 210 type => 'leaf', 211 value_type => 'enum', 212 level => 'hidden', 213 'warp' => { 214 follow => '- macro', 215 'rules' => [ 216 [qw/A D/] => { 217 choice => [qw/Av Bv/], 218 level => 'normal', 219 help => { Av => 'Av help' }, 220 }, 221 B => { 222 choice => [qw/Bv Cv/], 223 level => 'normal', 224 help => { Bv => 'Bv help' }, 225 }, 226 C => { 227 choice => [qw/Cv/], 228 level => 'normal', 229 help => { Cv => 'Cv help' }, 230 } ] } 231 }, 232 'compute' => { 233 type => 'leaf', 234 value_type => 'string', 235 compute => { 236 formula => 'macro is $m, my element is &element', 237 variables => { 'm' => '! macro' }, 238 }, 239 }, 240 241 'var_path' => { 242 type => 'leaf', 243 value_type => 'string', 244 mandatory => 1, # will croak if value cannot be computed 245 compute => { 246 formula => 'get_element is $replace{$s}, indirect value is \'$v\'', 247 variables => { 248 's' => '! $where', 249 where => '! where_is_element', 250 v => '! $replace{$s}', 251 }, 252 replace => {qw/m_value_element m_value compute_element compute/} } 253 }, 254 255 'class' => { 256 type => 'hash', 257 index_type => 'string', 258 cargo => { 259 type => 'leaf', 260 value_type => 'string' 261 }, 262 }, 263 'warped_out_ref' => { 264 type => 'leaf', 265 refer_to => '! class', 266 value_type => 'reference', 267 level => 'hidden', 268 warp => { 269 follow => { m => '- macro', m2 => '- macro2' }, 270 rules => [ '$m eq "A" or $m2 eq "A"' => { level => 'normal', }, ] 271 } 272 }, 273 274 [qw/bar foo foo2/] => { 275 type => 'node', 276 config_class_name => 'Slave' 277 }, 278 'ClientAliveCheck', 279 { 280 'value_type' => 'boolean', 281 'upstream_default' => '0', 282 'type' => 'leaf', 283 }, 284 'ClientAliveInterval', 285 { 286 'value_type' => 'integer', 287 'level' => 'hidden', 288 'min' => '1', 289 'warp' => { 290 'follow' => { 'c_a_check' => '- ClientAliveCheck' }, 291 'rules' => [ '$c_a_check == 1', { 'level' => 'normal' } ] 292 }, 293 'type' => 'leaf' 294 }, 295 # a bit dumb, but required to test warp from computed value 296 'compute_simple' => { 297 type => 'leaf', 298 value_type => 'string', 299 compute => { 300 formula => 'my element is &element', 301 }, 302 }, 303 warped_from_computed_value => { 304 type => 'leaf', 305 value_type => 'string', 306 level => 'hidden', 307 default => 'hello', 308 warp => { 309 follow => { c => '- compute_simple' }, 310 rules => [ '$c =~ /simple/' => { level => 'normal', }, ] 311 } 312 } 313 ] ); 314 315my $inst = $model->instance( 316 root_class_name => 'Master', 317 instance_name => 'test1' 318); 319ok( $inst, "created dummy instance" ); 320 321my $root = $inst->config_root; 322 323my $mvo = $root->fetch_element('m_value_out'); 324isa_ok( $mvo->{warper}, 'Config::Model::Warper', "check warper object" ); 325 326my $macro = $root->fetch_element('macro'); 327 328my @macro_slaves = ('Warper of Master m_value_out'); 329 330eq_or_diff( [ map { $_->name } $macro->get_depend_slave ], 331 \@macro_slaves, "check m_value_out warper" ); 332 333my $mvo2 = $root->fetch_element('m2_value_out'); 334isa_ok( $mvo2->{warper}, 'Config::Model::Warper', "check warper object" ); 335 336push @macro_slaves, 'Warper of Master m2_value_out', 'Warper of Master macro2'; 337 338eq_or_diff( 339 [ sort map { $_->name } $macro->get_depend_slave ], 340 [ sort @macro_slaves ], 341 "check m_value_out and m2_value_out warper" 342); 343 344eq_or_diff( 345 [ $root->get_element_name() ], 346 [ 347 qw'get_element where_is_element macro m_value_out m2_value_out 348 compute var_path class bar foo foo2 ClientAliveCheck 349 compute_simple warped_from_computed_value' 350 ], 351 "Elements of Master" 352); 353 354# query the model instead of the instance 355eq_or_diff( [ 356 $model->get_element_name( 357 class => 'Slave', 358 ) 359 ], 360 [qw'X Y Z recursive_slave Comp warped_by_location'], 361 "Elements of Slave from the model" 362); 363 364my $slave = $root->fetch_element('bar'); 365ok( $slave, "Created slave(bar)" ); 366 367eq_or_diff( 368 [ $slave->get_element_name() ], 369 [qw'X Y Z recursive_slave Comp warped_by_location'], 370 "Elements of Slave from the object" 371); 372 373throws_ok { $slave->fetch_element('W')->fetch; } 374 qr/unavailable/, "reading slave->W (undef value_type error)"; 375 376is( $slave->fetch_element('X')->fetch, undef, "reading slave->X (undef)" ); 377 378is( $macro->store('B'), 1, "setting master->macro to B" ); 379 380eq_or_diff( 381 [ $root->get_element_name() ], 382 [ 383 qw'get_element where_is_element macro m2_value_out macro2 m_value 384 m_value_old compute var_path class bar foo foo2 385 ClientAliveCheck compute_simple warped_from_computed_value' 386 ], 387 "Elements of Master when macro = B" 388); 389 390is( $root->fetch_element('macro2')->store('A'), 1, "setting master->macro2 to A" ); 391 392is_deeply( 393 [ $root->get_element_name() ], 394 [ 395 qw'get_element where_is_element macro macro2 396 m_value m_value_old compute var_path class warped_out_ref bar 397 foo foo2 ClientAliveCheck compute_simple warped_from_computed_value' 398 ], 399 "Elements of Master when macro = B macro2 = A" 400); 401 402$root->fetch_element('class')->fetch_with_id('foo')->store('foo_v'); 403$root->fetch_element('class')->fetch_with_id('bar')->store('bar_v'); 404 405is( $root->fetch_element('warped_out_ref')->store('foo'), 406 1, "setting master->warped_out_ref to foo" ); 407 408is( $root->fetch_element('macro')->store('A'), 1, "setting master->macro to A" ); 409 410foreach (qw/X Y Z/) { is( $slave->fetch_element($_)->fetch, 'Av', "reading slave->$_ (Av)" ); } 411 412is( $root->fetch_element('macro')->store('C'), 1, "setting master->macro to C" ); 413 414is( $root->fetch_element('m_value')->get_help('Cv'), 'Cv help', 'test m_value help with macro=C' ); 415 416is( $slave->fetch_element('X')->fetch, undef, "reading slave->X (undef)" ); 417 418$root->fetch_element('macro')->store('A'); 419 420is( $root->fetch_element('m_value')->store('Av'), 1, 'test m_value with macro=A' ); 421 422is( $root->fetch_element('m_value_old')->store('Av'), 1, 'test m_value_old with macro=A' ); 423 424is( $root->fetch_element('m_value')->get_help('Av'), 'Av help', 'test m_value help with macro=A' ); 425 426is( $root->fetch_element('m_value')->get_help('Cv'), undef, 'test m_value help with macro=A' ); 427 428$root->fetch_element('macro')->store('D'); 429 430is( $root->fetch_element('warped_from_computed_value')->fetch, 'hello', "check 'warped_from_computed_value"); 431 432is( $root->fetch_element('m_value')->fetch, 'Av', 'test m_value with macro=D' ); 433 434is( $root->fetch_element('m_value_old')->fetch, 'Av', 'test m_value_old with macro=D' ); 435 436$root->fetch_element('macro')->store('A'); 437 438is_deeply( 439 [ $slave->get_element_name() ], 440 [qw/X Y Z recursive_slave W Comp warped_by_location/], 441 "Slave elements from the object (W pops in when macro is set to A)" 442); 443$root->fetch_element('macro')->store('B'); 444 445is_deeply( 446 [ $slave->get_element_name() ], 447 [qw/X Y Z recursive_slave W Comp warped_by_location/], 448 "Slave elements from the object" 449); 450 451foreach (qw/X Y Z/) { is( $slave->fetch_element($_)->fetch, 'Bv', "reading slave->$_ (Bv)" ); } 452 453is( $slave->fetch_element('Y')->store('Cv'), 1, 'Set slave->Y to Cv' ); 454 455# testing warp in warp out 456$root->fetch_element('macro')->store('C'); 457is( $slave->is_element_available( name => 'W' ), 458 0, " test W is not available" ); 459$root->fetch_element('macro')->store('B'); 460is( $slave->is_element_available( name => 'W' ), 461 1, " test W is available" ); 462 463$root->fetch_element('macro')->store('C'); 464 465foreach (qw/X Z/) { is( $slave->fetch_element($_)->fetch, undef, "reading slave->$_ (undef)" ); } 466is( $slave->fetch_element('Y')->fetch, 'Cv', "reading slave->Y (Cv)" ); 467 468is( $slave->fetch_element('Comp')->fetch, 'macro is C', "reading slave->Comp" ); 469 470is( $root->fetch_element('m_value')->store('Cv'), 1, 'set m_value to Cv' ); 471 472my $rslave1 = $slave->fetch_element('recursive_slave')->fetch_with_id('l1'); 473my $rslave2 = $rslave1->fetch_element('recursive_slave')->fetch_with_id('l2'); 474my $big_compute_obj = $rslave2->fetch_element('big_compute')->fetch_with_id('b1'); 475 476isa_ok( $big_compute_obj, 'Config::Model::Value', 'Created new big compute object' ); 477 478my $bc_val = $rslave2->fetch_element('big_compute')->fetch_with_id("test_1")->fetch; 479 480is( 481 $bc_val, 482 'macro is C, my idx: test_1, my element big_compute, upper element recursive_slave, up idx l2', 483 'reading slave->big_compute(test1)' 484); 485 486is( 487 $big_compute_obj->fetch, 488 'macro is C, my idx: b1, my element big_compute, upper element recursive_slave, up idx l2', 489 'reading slave->big_compute(b1)' 490); 491 492is( 493 $rslave1->fetch_element('big_replace')->fetch(), 494 'trad idx level1', 495 'reading rslave1->big_replace(br1)' 496); 497 498is( 499 $rslave2->fetch_element('big_replace')->fetch(), 500 'trad idx level2', 501 'reading rslave2->big_replace(br1)' 502); 503 504is( 505 $rslave1->fetch_element('macro_replace')->fetch_with_id('br1')->fetch, 506 'trad macro is macroC', 507 'reading rslave1->macro_replace(br1)' 508); 509 510is( 511 $rslave2->fetch_element('macro_replace')->fetch_with_id('br1')->fetch, 512 'trad macro is macroC', 513 'reading rslave2->macro_replace(br1)' 514); 515 516is( 517 $root->fetch_element('compute')->fetch(), 518 'macro is C, my element is compute', 519 'reading root->compute' 520); 521 522my @masters = $root->fetch_element('macro')->get_depend_slave(); 523my @names = sort map { $_->name } @masters; 524print "macro controls:\n\t", join( "\n\t", @names ), "\n" 525 if $trace; 526 527is( scalar @masters, 16, 'reading macro slaves' ); 528 529eq_or_diff( 530 \@names, 531 [ 532 'Master compute', 533 'Warper of Master m2_value_out', 534 'Warper of Master m_value', 535 'Warper of Master m_value_old', 536 'Warper of Master m_value_out', 537 'Warper of Master macro2', 538 'Warper of Master warped_out_ref', 539 'Warper of bar W', 540 'Warper of bar X', 541 'Warper of bar Y', 542 'Warper of bar Z', 543 'bar Comp', 544 'bar recursive_slave:l1 macro_replace:br1', 545 'bar recursive_slave:l1 recursive_slave:l2 big_compute:b1', 546 'bar recursive_slave:l1 recursive_slave:l2 big_compute:test_1', 547 'bar recursive_slave:l1 recursive_slave:l2 macro_replace:br1', 548 ], 549 "check names of values using 'macro' element" 550); 551 552Config::Model::Exception::Any->Trace(1); 553 554throws_ok { $root->fetch_element('var_path')->fetch; } 555 qr/'! where_is_element' is undef/, 556 'reading var_path while where_is_element variable is undef'; 557 558# set one variable of the formula 559$root->fetch_element('where_is_element')->store('get_element'); 560 561throws_ok { $root->fetch_element('var_path')->fetch; } 562 qr/'! where_is_element' is 'get_element'/, 563 'reading var_path while where_is_element is defined' ; 564throws_ok { $root->fetch_element('var_path')->fetch; } 565 qr/Undefined mandatory value/, 'reading var_path while get_element variable is undef'; 566 567# set the other variable of the formula 568$root->fetch_element('get_element')->store('m_value_element'); 569 570is( 571 $root->fetch_element('var_path')->fetch(), 572 'get_element is m_value, indirect value is \'Cv\'', 573 "reading var_path through m_value element" 574); 575 576# modify the other variable of the formula 577$root->fetch_element('get_element')->store('compute_element'); 578 579is( 580 $root->fetch_element('var_path')->fetch(), 581 'get_element is compute, indirect value is \'macro is C, my element is compute\'', 582 "reading var_path through compute element" 583); 584 585$root->fetch_element('ClientAliveCheck')->store(0); 586 587throws_ok { $root->fetch_element('ClientAliveInterval')->fetch; } 588 qr/unavailable element/, 'reading ClientAliveInterval when ClientAliveCheck is 0'; 589 590$root->fetch_element('ClientAliveCheck')->store(1); 591$root->fetch_element('ClientAliveInterval')->store(10); 592is( $root->fetch_element('ClientAliveInterval')->fetch, 10, "check ClientAliveInterval" ); 593 594my %loc_h = ( 595 qw/bar slaved foo2 slaved/, 596 'bar recursive_slave:l1 foo2' => 'rslaved', 597 'bar recursive_slave:l1 recursive_slave:l2 foo2' => 'rslaved' 598); 599 600foreach my $k ( sort keys %loc_h ) { 601 my $path = "$k warped_by_location"; 602 is( $root->grab_value($path), $loc_h{$k}, "check &location with $path" ); 603} 604 605# test warp in layered mode 606my $layered_i = $model->instance( 607 root_class_name => 'Master', 608 instance_name => 'test_layered' 609); 610ok( $layered_i, "created layered instance" ); 611 612my $l_root = $layered_i->config_root; 613$layered_i->layered_start; 614 615my $l_macro = $l_root->fetch_element('macro'); 616 617$l_macro->store('D'); 618 619my $l_mv = $l_root->fetch_element('m_value'); 620$layered_i->layered_stop; 621 622$l_mv->store('Av'); 623is( $l_mv->fetch, 'Av', "test warp in layered mode" ); 624 625memory_cycle_ok( $model, "test memory cycle" ); 626 627done_testing ; 628