t/check_list.t - metacpan.org

# -*- cperl -*-

use warnings;

use ExtUtils::testlib;
use Test::More;
use Test::Differences;
use Test::Memory::Cycle;
use Config::Model;
use Data::Dumper;
use Log::Log4perl qw(:easy :levels);

use strict;

my $arg = shift || '';
my ( $log, $show ) = (0) x 2;

my $trace = $arg =~ /t/ ? 1 : 0;
$log  = 1 if $arg =~ /l/;
$show = 1 if $arg =~ /s/;

my $home = $ENV{HOME} || "";
my $log4perl_user_conf_file = "$home/.log4config-model";

if ( $log and -e $log4perl_user_conf_file ) {
    Log::Log4perl::init($log4perl_user_conf_file);
}
else {
    Log::Log4perl->easy_init( $log ? $WARN : $ERROR );
}

Config::Model::Exception::Any->Trace(1) if $arg =~ /e/;

ok( 1, "Compilation done" );

# minimal set up to get things working
my $model = Config::Model->new();
$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" );

# test with the polymorphic 'store' method
$cl->store( value => 'S,T ,  O, R, E' );
ok( 1, "test store method" );
@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;

# test with the polymorphic 'set' method
$cl->set( '', 'A,Z,Y,B' );
ok( 1, "test set method" );
@got = $cl->get_checked_list;
is( scalar @got, 4, "test nb of elt in check_list after set" );
is_deeply( \@got, [qw/A B Y Z/], "test get_checked_list after set" );

is( $inst->needs_save, 1, "verify instance needs_save after set" );
print join( "\n", $inst->list_changes("\n") ), "\n" if $trace;
$inst->clear_changes;

my @set = sort qw/A C Z V Y/;
$cl->set_checked_list(@set);
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;
$inst->clear_changes;

# test global get and set as hash
$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;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)