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