# -*- cperl -*-
use warnings;
use strict;
use ExtUtils::testlib;
use Test::More;
use Test::Differences;
use Test::Memory::Cycle;
use Test::Log::Log4perl;
use Test::Exception;
use Config::Model;
use Config::Model::Tester::Setup qw/init_test/;
my ($model, $trace) = init_test();
# minimal set up to get things working
$model->create_config_class(
name => "Master",
element => [
[qw/my_hash my_hash2 my_hash3/] => {
type => 'hash',
index_type => 'string',
cargo => { type => 'leaf', value_type => 'string' },
},
choice_list => {
type => 'check_list',
choice => [ 'A' .. 'Z' ],
help => { A => 'A help', E => 'E help' },
},
ordered_checklist => {
type => 'check_list',
choice => [ 'A' .. 'Z' ],
ordered => 1,
help => { A => 'A help', E => 'E help' },
},
ordered_checklist_refer_to => {
type => 'check_list',
refer_to => '- ordered_checklist',
ordered => 1,
},
choice_list_with_default => {
type => 'check_list',
choice => [ 'A' .. 'Z' ],
default_list => [ 'A', 'D' ],
help => { A => 'A help', E => 'E help' },
},
choice_list_with_upstream_default => {
type => 'check_list',
choice => [ 'A' .. 'Z' ],
upstream_default_list => [ 'A', 'D' ],
help => { A => 'A help', E => 'E help' },
},
choice_list_with_default_and_upstream_default => {
type => 'check_list',
choice => [ 'A' .. 'Z' ],
default_list => [ 'A', 'C' ],
upstream_default_list => [ 'A', 'D' ],
help => { A => 'A help', E => 'E help' },
},
macro => {
type => 'leaf',
value_type => 'enum',
choice => [qw/AD AH AZ/],
},
'warped_choice_list' => {
type => 'check_list',
level => 'hidden',
warp => {
follow => '- macro',
rules => {
AD => {
choice => [ 'A' .. 'D' ],
level => 'normal',
default_list => [ 'A', 'B' ]
},
AH => {
choice => [ 'A' .. 'H' ],
level => 'normal',
},
} }
},
refer_to_list => {
type => 'check_list',
refer_to => '- my_hash'
},
warped_refer_to_list => {
type => 'check_list',
refer_to => '- warped_choice_list',
level => 'hidden',
warp => {
follow => '- macro',
rules => {
AD => {
choice => [ 'A' .. 'D' ],
level => 'normal',
},
},
},
},
refer_to_2_list => {
type => 'check_list',
refer_to => '- my_hash + - my_hash2 + - my_hash3'
},
refer_to_check_list_and_choice => {
type => 'check_list',
computed_refer_to => {
formula => '- refer_to_2_list + - $var',
variables => { var => '- indirection ' },
},
choice => [qw/A1 A2 A3/],
},
indirection => { type => 'leaf', value_type => 'string' },
dumb_list => {
type => 'list',
cargo => { type => 'leaf', value_type => 'string' }
},
refer_to_dumb_list => {
type => 'check_list',
refer_to => '- dumb_list + - my_hash',
},
'Ciphers',
{
'ordered' => '1',
'upstream_default_list' => [
'3des-cbc', 'aes128-cbc', 'aes128-ctr', 'aes192-cbc',
'aes192-ctr', 'aes256-cbc', 'aes256-ctr', 'arcfour',
'arcfour128', 'arcfour256', 'blowfish-cbc', 'cast128-cbc'
],
'type' => 'check_list',
'description' =>
'Specifies the ciphers allowed for protocol version 2 in order of preference. By default, all ciphers are allowed.',
'choice' => [
'aes128-cbc', '3des-cbc', 'blowfish-cbc', 'cast128-cbc',
'arcfour128', 'arcfour256', 'arcfour', 'aes192-cbc',
'aes256-cbc', 'aes128-ctr', 'aes192-ctr', 'aes256-ctr'
]
},
] );
my $inst = $model->instance(
root_class_name => 'Master',
instance_name => 'test1'
);
ok( $inst, "created dummy instance" );
$inst->initial_load_stop;
my $root = $inst->config_root;
my $cl = $root->fetch_element('choice_list');
# check get_choice
is_deeply( [ $cl->get_choice ], [ 'A' .. 'Z' ], "check_get_choice" );
is( $inst->needs_save, 0, "verify instance needs_save status after creation" );
ok( 1, "test get_checked_list for empty check_list" );
my @got = $cl->get_checked_list;
is( scalar @got, 0, "test nb of elt in check_list " );
is_deeply( \@got, [], "test get_checked_list after set_checked_list" );
my %expect;
my $hr = $cl->get_checked_list_as_hash;
is_deeply( $hr, \%expect, "test get_checked_list_as_hash for empty checklist" );
# check help
is( $cl->get_help('A'), 'A help', "test help" );
is( $inst->needs_save, 0, "verify instance needs_save status after reading meta data" );
subtest 'test _store method' => sub {
# test with the polymorphic 'store' method
my @test_args = (
[ [ 'S', 1, 'yes' ], 1, ['S'] ],
[ [ 'A', 1, 'yes' ], 2, ['A','S'] ],
[ [ 'A', 0, 'yes' ], 1, ['S'] ],
[ [ 'bug', 1, 'skip' ], 1, ['S'] ],
);
foreach my $test_arg_ref ( @test_args) {
my ($args, $nb, $expect) = @$test_arg_ref;
$cl->_store( @$args );
ok( 1, "test _store method with @$args" );
@got = $cl->get_checked_list;
is( scalar @got, $nb, "test nb of elt in check_list after _store" );
is_deeply( \@got, $expect, "test get_checked_list after _store" );
$inst->clear_changes;
}
};
subtest 'test _store warning' => sub {
my $foo = Test::Log::Log4perl->expect(
ignore_priority => 'info',
['Tree.Element.CheckList', warn => qr/Unknown check_list item/ ]
);
$cl->_store('bug-skipped', 1, 'skip');
};
throws_ok { $cl->_store('bug-error', 1, 'yes') } qr/wrong value/, 'test _store error';
subtest 'test store method' => sub {
# test with the polymorphic 'store' method
my @store_args = (
[ 'S,T,O,R,E' ],
[ value => 'S,T , O, R, E' ],
[ 'S,O,T,R,E', check => 'yes' ],
[ value => 'S,T , O, R, E', check => 'yes' ],
[ 'S,T,O,R,E,bug', check => 'yes' ],
);
foreach my $test_arg ( @store_args) {
$cl->store( @$test_arg );
ok( 1, "test store method with @$test_arg" );
@got = $cl->get_checked_list;
is( scalar @got, 5, "test nb of elt in check_list after set" );
is_deeply( \@got, [sort qw/S T O R E/], "test get_checked_list after set" );
$inst->clear_changes;
}
};
$cl->clear;
subtest "test set method and reported changes" => sub {
my @set_args = (
# set string, changes , content after changes
[ 'A,B' => 'A:1 B:1',qw/A B/],
[ 'A,B,C' => 'C:1', qw/A B C/],
[ 'A,C,D' => 'B:0 D:1', qw/A C D/],
);
while (@set_args) {
my $test = shift @set_args;
my ($set_string, $expected_changes, @expected_content) = @$test;
$cl->set( '', $set_string );
ok( 1, "test set method with $set_string" );
@got = $cl->get_checked_list;
is_deeply( \@got, \@expected_content, "test get_checked_list content after set" );
is( $inst->needs_save, !!$expected_changes, "verify instance needs_save after set" );
print join( "\n", $inst->list_changes("\n") ), "\n" if $trace;
eq_or_diff([$inst->list_changes], ["choice_list: set_checked_list $expected_changes"],
"check change message after set check list to $set_string");
$inst->clear_changes;
}
};
$cl->clear;
$inst->clear_changes;
my @set = sort qw/A C Z V Y/;
subtest "test get_arguments" => sub {
my @set_args = (
\@set,
[ \@set ],
[ \@set , check => 'yes' ],
);
foreach my $test_arg ( @set_args) {
my ($list, $check, $args) = $cl->get_arguments(@$test_arg);
ok( 1, "test set_checked_list" );
eq_or_diff($list, \@set, "test passed list");
}
};
subtest 'test set_checked_list method' => sub {
my @set_args = (
\@set,
[ \@set ],
[ \@set , check => 'yes' ],
[ [ sort qw/A C Z V Y bug/ ] , check => 'skip' ],
);
foreach my $test_arg ( @set_args) {
$cl->set_checked_list(@$test_arg);
ok( 1, "test set_checked_list" );
@got = $cl->get_checked_list;
is( scalar @got, 5, "test nb of elt in check_list after set_checked_list" );
is_deeply( \@got, \@set, "test get_checked_list after set_checked_list" );
is( $inst->needs_save, 1, "verify instance needs_save after set_checked_list" );
print join( "\n", $inst->list_changes("\n") ), "\n" if $trace;
$cl->clear;
$inst->clear_changes;
}
};
$cl->clear;
$inst->clear_changes;
# test global get and set as hash
$cl->set_checked_list(@set);
$hr = $cl->get_checked_list_as_hash;
map { $expect{$_} = 0 } ( 'A' .. 'Z' );
map { $expect{$_} = 1 } @set;
eq_or_diff( $hr, \%expect, "test get_checked_list_as_hash" );
$expect{V} = 0;
$expect{W} = 1;
$cl->set_checked_list_as_hash(%expect);
ok( 1, "test set_checked_list_as_hash" );
@got = sort $cl->get_checked_list;
is_deeply( \@got, [ sort qw/A C Z W Y/ ], "test get_checked_list after set_checked_list_as_hash" );
$cl->clear;
# test global get and set
@got = $cl->get_checked_list;
is( scalar @got, 0, "test nb of elt in check_list after clear" );
eval { $cl->check('a'); };
ok( $@, "check 'a': which is an error" );
print "normal error:\n", $@, "\n" if $trace;
# test layered choice_list
$inst->layered_start;
my @l_set = qw/B M W/;
$cl->set_checked_list(@l_set);
$inst->layered_stop;
eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], \@l_set, "check layered content" );
eq_or_diff( [ $cl->get_checked_list( mode => 'standard' ) ], \@l_set, "check standard content" );
eq_or_diff( [ $cl->get_checked_list() ], [], "check user content" );
$cl->set_checked_list_as_hash( V => 1, W => 1 );
eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ], \@l_set, "check layered content" );
eq_or_diff( [ $cl->get_checked_list( mode => 'standard' ) ], \@l_set, "check standard content" );
eq_or_diff( [ $cl->get_checked_list( mode => 'user' ) ], [qw/B M V W/], "check user content" );
eq_or_diff( [ $cl->get_checked_list() ], [qw/V W/], "check content" );
$cl->clear_layered;
eq_or_diff( [ $cl->get_checked_list( mode => 'layered' ) ],
[], "check layered content after clear" );
# now test with a refer_to parameter
$root->load("my_hash:X=x my_hash:Y=y");
ok( 1, "load my_hash:X=x my_hash:Y=y worked correctly" );
my $rflist = $root->fetch_element('refer_to_list');
ok( $rflist, "created refer_to_list" );
is_deeply( [ $rflist->get_choice ], [qw/X Y/], 'check simple refer choices' );
$root->load("my_hash:Z=z");
ok( 1, "load my_hash:Z=z worked correctly" );
is_deeply( [ $rflist->get_choice ], [qw/X Y Z/], 'check simple refer choices after 2nd load' );
# load hashes that are used by reference check list
$root->load("my_hash2:X2=x my_hash2:X=xy");
my $rf2list = $root->fetch_element('refer_to_2_list');
ok( $rf2list, "created refer_to_2_list" );
is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 Y Z/], 'check refer_to_2_list choices' );
$root->load("my_hash3:Y2=y");
is_deeply( [ sort $rf2list->get_choice ], [qw/X X2 Y Y2 Z/], 'check refer_to_2_list choices' );
my $rtclac = $root->fetch_element('refer_to_check_list_and_choice');
ok( $rtclac, "created refer_to_check_list_and_choice" );
is_deeply( [ sort $rtclac->get_choice ],
[qw/A1 A2 A3/], 'check refer_to_check_list_and_choice choices' );
eval { $rtclac->check('X'); };
ok( $@, "get_choice with undef 'indirection' parm: which is an error" );
print "normal error:\n", $@, "\n" if $trace;
$root->fetch_element('indirection')->store('my_hash');
is_deeply( [ sort $rtclac->get_choice ],
[qw/A1 A2 A3 X Y Z/], 'check refer_to_check_list_and_choice choices with indirection set' );
$rf2list->check('X2');
is_deeply(
[ sort $rtclac->get_choice ],
[ sort qw/A1 A2 A3 X X2 Y Z/ ],
'check X2 and test choices'
);
# load hashes that are used by reference check list
$root->load("my_hash2:X3=x");
$rf2list->check( 'X3', 'Y2' );
is_deeply( [ sort $rf2list->get_choice ],
[qw/X X2 X3 Y Y2 Z/], 'check refer_to_2_list choices with X3' );
is_deeply(
[ sort $rtclac->get_choice ],
[qw/A1 A2 A3 X X2 X3 Y Y2 Z/],
'check refer_to_check_list_and_choice choices'
);
my $dflist = $root->fetch_element('choice_list_with_default');
ok( $dflist, "created choice_list_with_default" );
@got = $dflist->get_checked_list;
is_deeply( \@got, [ 'A', 'D' ], "test default of choice_list_with_default" );
@got = $dflist->get_checked_list(mode =>'custom');
is_deeply( \@got, [ ], "test custom data of choice_list_with_default" );
is($dflist->has_data, 0, "choice_list_with_default has no data");
$dflist->check('C');
$dflist->uncheck('D');
@got = $dflist->get_checked_list;
is_deeply( \@got, [ 'A', 'C' ], "test default of choice_list_with_default" );
is($dflist->has_data, 1, "choice_list_with_default has data");
@got = $dflist->get_checked_list('custom');
is_deeply( \@got, ['C'], "test custom of choice_list_with_default" );
@got = $dflist->get_checked_list('standard');
is_deeply( \@got, [ 'A', 'D' ], "test standard of choice_list_with_default" );
my $warp_list;
eval { $warp_list = $root->fetch_element('warped_choice_list'); };
ok( $@, "fetch_element without warp set (macro=undef): which is an error" );
print "normal error:\n", $@, "\n" if $trace;
# force read of hidden element
$warp_list = $root->fetch_element( name => 'warped_choice_list', accept_hidden => 1 );
ok( $warp_list, "created warped_choice_list" );
eval { $warp_list->get_choice; };
ok( $@, "get_choice without warp set (macro=undef): which is an error" );
print "normal error:\n", $@, "\n" if $trace;
$root->load("macro=AD");
is_deeply(
[ $warp_list->get_choice ],
[ 'A' .. 'D' ],
'check warp_list choice after setting macro=AD'
);
@got = $warp_list->get_checked_list;
is_deeply( \@got, [ 'A', 'B' ], "test default of warped_choice_list" );
$root->load("macro=AH");
is_deeply(
[ $warp_list->get_choice ],
[ 'A' .. 'H' ],
'check warp_list choice after setting macro=AH'
);
@got = $warp_list->get_checked_list;
is_deeply( \@got, [], "test default of warped_choice_list after setting macro=AH" );
# test reference to list values
$root->load("dumb_list=a,b,c,d,e");
my $rtl = $root->fetch_element("refer_to_dumb_list");
is_deeply( [ $rtl->get_choice ], [qw/X Y Z a b c d e/], "check choice of refer_to_dumb_list" );
# test check list with built_in default
my $wud = $root->fetch_element("choice_list_with_upstream_default");
@got = $wud->get_checked_list();
is_deeply( \@got, [], "test default of choice_list_with_upstream_default" );
@got = $wud->get_checked_list('upstream_default');
is_deeply( \@got, [qw/A D/], "test upstream_default of choice_list_with_upstream_default" );
# test check list with upstream_default *and* default (should override)
$inst->clear_changes;
my $wudad = $root->fetch_element("choice_list_with_default_and_upstream_default");
is( $inst->needs_save, 0, "check needs_save after reading a default value" );
@got = $wudad->get_checked_list('default');
is_deeply( \@got, [qw/A C/], "test default of choice_list_with_default_and_upstream_default" );
is( $inst->needs_save, 0, "check needs_save after reading a default value" );
@got = $wudad->get_checked_list();
is_deeply( \@got, [qw/A C/], "test choice_list_with_default_and_upstream_default" );
is( $inst->needs_save, 1, "check needs_save after reading a default value" );
is_deeply( $wudad->fetch(), 'A,C', "test fetch choice_list_with_default_and_upstream_default" );
is( $inst->needs_save, 1, "check needs_save after reading a default value" );
### test preset feature
my $pinst = $model->instance(
root_class_name => 'Master',
instance_name => 'preset_test'
);
ok( $pinst, "created dummy preset instance" );
my $p_root = $pinst->config_root;
$pinst->preset_start;
ok( $pinst->preset, "instance in preset mode" );
my $p_cl = $p_root->fetch_element('choice_list');
$p_cl->set_checked_list(qw/H C L/); # acid burn test :-)
$pinst->preset_stop;
is( $pinst->preset, 0, "instance in normal mode" );
is( $p_cl->fetch, "C,H,L", "choice_list: read preset list" );
$p_cl->check(qw/A S H/);
is( $p_cl->fetch, "A,C,H,L,S", "choice_list: read completed preset LIST" );
is( $p_cl->fetch('preset'), "C,H,L", "choice_list: read preset value as preset_value" );
is( $p_cl->fetch('standard'), "C,H,L", "choice_list: read preset value as standard_value" );
is( $p_cl->fetch('custom'), "A,C,H,L,S", "choice_list: read custom_value" );
$p_cl->set_checked_list(qw/A S H E/);
is( $p_cl->fetch, "A,E,H,S", "choice_list: read overridden preset LIST" );
is( $p_cl->fetch('custom'), "A,E,H,S", "choice_list: read custom_value after override" );
my $wrtl = $p_root->fetch_element( name => 'warped_refer_to_list', accept_hidden => 1 );
ok( $wrtl, "created warped_refer_to_list (hidden)" );
my $ocl = $root->fetch_element('ordered_checklist');
@got = $ocl->get_checked_list();
is_deeply( \@got, [], "test default of ordered_checklist" );
@set = qw/A C Z V Y/;
$ocl->set_checked_list(@set);
@got = $ocl->get_checked_list;
is_deeply( \@got, \@set, "test ordered_checklist after set_checked_list" );
$ocl->swap(qw/A Y/);
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y C Z V A/], "test ordered_checklist after swap" );
$ocl->move_up(qw/Y/);
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y C Z V A/], "test ordered_checklist after move_up Y" );
$ocl->move_up(qw/V/);
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y C V Z A/], "test ordered_checklist after move_up V" );
$ocl->move_down(qw/A/);
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y C V Z A/], "test ordered_checklist after move_down A" );
$ocl->move_down(qw/C/);
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y V C Z A/], "test ordered_checklist after move_down C" );
$ocl->check('B');
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y V C Z A B/], "test ordered_checklist after check B" );
$ocl->move_up(qw/B/);
$ocl->uncheck('B');
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y V C Z A/], "test ordered_checklist after move_up B uncheck B" );
$ocl->check('B');
@got = $ocl->get_checked_list;
is_deeply( \@got, [qw/Y V C Z B A/], "test ordered_checklist after check B" );
is( $root->grab_value( $ocl->location ), "Y,V,C,Z,B,A", "test grab_value" );
my $oclrt = $root->fetch_element('ordered_checklist_refer_to');
@got = $oclrt->get_choice();
is_deeply( \@got, [qw/Y V C Z B A/], "test default of ordered_checklist_refer_to" );
my $ciphers = $root->fetch_element('Ciphers');
my @cipher_list = qw/aes192-cbc aes128-cbc 3des-cbc blowfish-cbc aes256-cbc/;
$ciphers->set_checked_list(@cipher_list);
eq_or_diff( [ $ciphers->get_checked_list ], \@cipher_list, "check cipher list" );
# test warp in layered mode
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 $locl = $l_root->fetch_element('ordered_checklist');
$locl->set_checked_list(@set);
my $loclrt = $root->fetch_element('ordered_checklist_refer_to');
@got = $loclrt->get_choice();
is_deeply( \@got, [qw/Y V C Z B A/], "test default of ordered_checklist_refer_to in layered mode" );
$inst->apply_fixes;
ok( 1, "apply_fixes works" );
print join( "\n", $inst->list_changes("\n") ), "\n" if $trace;
memory_cycle_ok( $model, "memory cycle" );
done_testing;