# -*- cperl -*-
use warnings FATAL => qw(all);
use ExtUtils::testlib;
use Test::More tests => 19;
use Test::Memory::Cycle;
use Config::Model;
use strict;
my $arg = shift || '';
my $trace = $arg =~ /t/ ? 1 : 0;
$::debug = 1 if $arg =~ /d/;
Config::Model::Exception::Any->Trace(1) if $arg =~ /e/;
use Log::Log4perl qw(:easy);
Log::Log4perl->easy_init( $arg =~ /l/ ? $TRACE : $WARN );
ok( 1, "Compilation done" );
# minimal set up to get things working
my $model = Config::Model->new( legacy => 'ignore', );
$model->create_config_class(
name => 'Host',
'element' => [
if => {
type => 'hash',
index_type => 'string',
cargo_type => 'node',
config_class_name => 'If',
},
trap => {
type => 'leaf',
value_type => 'string'
} ] );
$model->create_config_class(
name => 'If',
element => [
ip => {
type => 'leaf',
value_type => 'string'
} ] );
$model->create_config_class(
name => 'Lan',
element => [
node => {
type => 'hash',
index_type => 'string',
cargo_type => 'node',
config_class_name => 'Node',
},
] );
$model->create_config_class(
name => 'Node',
element => [
host => {
type => 'leaf',
value_type => 'reference',
refer_to => '! host'
},
if => {
type => 'leaf',
value_type => 'reference',
refer_to => [ ' ! host:$h if ', h => '- host' ]
},
ip => {
type => 'leaf',
value_type => 'string',
compute => [
'$ip',
ip => '! host:$h if:$card ip',
h => '- host',
card => '- if'
] } ] );
$model->create_config_class(
name => 'Master',
element => [
host => {
type => 'hash',
index_type => 'string',
cargo_type => 'node',
config_class_name => 'Host'
},
lan => {
type => 'hash',
index_type => 'string',
cargo_type => 'node',
config_class_name => 'Lan'
},
host_and_choice => {
type => 'leaf',
value_type => 'reference',
refer_to => ['! host '],
choice => [qw/foo bar/]
},
dumb_list => {
type => 'list',
cargo_type => 'leaf',
cargo_args => { value_type => 'string' }
},
refer_to_list_enum => {
type => 'leaf',
value_type => 'reference',
refer_to => '- dumb_list',
},
refer_to_wrong_path => {
type => 'leaf',
value_type => 'reference',
refer_to => '! unknown_class unknown_elt',
},
refer_to_unknown_elt => {
type => 'leaf',
value_type => 'reference',
refer_to => '! unknown_elt',
},
] );
my $inst = $model->instance(
root_class_name => 'Master',
instance_name => 'test1'
);
ok( $inst, "created dummy instance" );
my $root = $inst->config_root;
ok( $root, "Created Root" );
$root->load(
' host:A if:eth0 ip=10.0.0.1 -
if:eth1 ip=10.0.1.1 - -
host:B if:eth0 ip=10.0.0.2 -
if:eth1 ip=10.0.1.2 - - '
);
ok( 1, "host setup done" );
my $node = $root->grab('lan:A node:1');
ok( $node, "got lan:A node:1" . $node->name );
$node->load('host=A');
is( $node->grab_value('host'), 'A', "setup host=A" );
$node->load('if=eth0');
is( $node->grab_value('if'), 'eth0', "set up if=eth0 " );
# magic
is( $node->grab_value('ip'), '10.0.0.1', "got ip 10.0.0.1" );
$root->load(
' lan:A node:2 host=B if=eth0 - -
lan:B node:1 host=A if=eth1 -
node:2 host=B if=eth1 - -
'
);
ok( 1, "lan setup done" );
is( $root->grab_value('lan:A node:1 ip'), '10.0.0.1', "got ip 10.0.0.1" );
is( $root->grab_value('lan:A node:2 ip'), '10.0.0.2', "got ip 10.0.0.2" );
is( $root->grab_value('lan:B node:1 ip'), '10.0.1.1', "got ip 10.0.1.1" );
is( $root->grab_value('lan:B node:2 ip'), '10.0.1.2', "got ip 10.0.1.2" );
#print distill_root( object => $root );
#print dump_root( object => $root );
my $hac = $root->fetch_element('host_and_choice');
is_deeply(
[ $hac->get_choice ],
[ 'A', 'B', 'bar', 'foo' ],
"check that default choice and refer_to add up"
);
# choice needs to be recomputed for references
$root->load("host~B");
is_deeply(
[ $hac->get_choice ],
[ 'A', 'bar', 'foo' ],
"check that default choice and refer_to follow removed elements"
);
# test reference to list values
$root->load("dumb_list=a,b,c,d,e");
my $rtle = $root->fetch_element("refer_to_list_enum");
is_deeply( [ $rtle->get_choice ], [qw/a b c d e/], "check choice of refer_to_list_enum" );
eval { $root->fetch_element("refer_to_wrong_path"); };
ok( $@, "fetching refer_to_wrong_path" );
print "normal error: $@" if $trace;
eval { $root->fetch_element("refer_to_unknown_elt") };
ok( $@, "fetching refer_to_unknown_elt" );
print "normal error: $@" if $trace;
memory_cycle_ok($model);