# -*- cperl -*-
use ExtUtils::testlib;
use Test::More ;
use Test::Exception;
use Test::Warn;
use Test::Memory::Cycle;
use Config::Model;
use warnings;
no warnings qw(once);
use strict;
my $arg = shift || '';
my $trace = $arg =~ /t/ ? 1 : 0;
$::verbose = 1 if $arg =~ /v/;
$::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, "compiled" );
my $model = Config::Model->new();
$model->create_config_class(
name => 'Sarge',
status => [ D => 'deprecated' ], #could be obsolete, standard
description => [ X => 'X-ray (long description)' ],
summary => [ X => 'X-ray (summary)' ],
element => [
[qw/D X Y Z/] => {
type => 'leaf',
class => 'Config::Model::Value',
value_type => 'enum',
choice => [qw/Av Bv Cv/] }
],
);
$model->create_config_class(
name => 'Captain',
element => [
bar => {
type => 'node',
config_class_name => 'Sarge'
} ] );
$model->create_config_class(
name => "Master",
level => [ qw/captain/ => 'important' ],
element => [
captain => {
type => 'node',
config_class_name => 'Captain',
},
[qw/array_args hash_args/] => {
type => 'node',
config_class_name => 'Captain',
},
],
class_description => "Master description",
description => [
captain => "officer",
array_args => 'not officer'
] );
ok( 1, "Model created" );
my $instance = $model->instance(
root_class_name => 'Master',
instance_name => 'test1'
);
ok( 1, "Instance created" );
my $root = $instance->config_root;
ok( $root, "Config root created" );
is( $root->config_class_name, 'Master', "Created Master" );
is_deeply(
[ sort $root->get_element_name( ) ],
[qw/array_args captain hash_args/],
"check Master elements"
);
is_deeply(
[ sort $root->get_element_name( ) ],
[qw/array_args captain hash_args/],
"check Master elements"
);
is_deeply(
[ sort $root->get_element_name( ) ],
[qw/array_args captain hash_args/],
"check Master elements"
);
my $w = $root->fetch_element('captain');
ok( $w, "Created Captain" );
is( $w->config_class_name, 'Captain', "test class_name" );
is( $w->element_name, 'captain', "test element_name" );
is( $w->name, 'captain', "test name" );
is( $w->location, 'captain', "test captain location" );
my $b = $w->fetch_element('bar');
ok( $b, "Created Sarge" );
is( $b->fetch_element_value('Z'), undef, "test Z value" );
warning_like { $b->fetch_element('D'); }
qr/Element 'D' of node 'captain bar' is deprecated/,
'Check deprecated element warning';
my $tested = $root->fetch_element('hash_args')->fetch_element('bar');
is( $tested->config_class_name, 'Sarge', "test bar config_class_name" );
is( $tested->element_name, 'bar', "test bar element_name" );
is( $tested->name, 'hash_args bar', "test bar name" );
is( $tested->location, 'hash_args bar', "test bar location" );
my $inst2 = $model->instance(
root_class_name => 'Master',
instance_name => 'test2'
);
isa_ok( $inst2, 'Config::Model::Instance', "Created 2nd Master" );
isa_ok( $inst2->config_root, 'Config::Model::Node', "created 2nd tree" );
# test help included with the model
is( $root->get_help, "Master description", "Test master global help" );
is( $root->get_help('captain'), "officer", "Test master slot help captain" );
is( $root->get_help('hash_args'), '', "Test master slot help hash_args" );
is( $tested->get_help('X'), "X-ray (long description)", "Test sarge slot help X" );
is(
$tested->get_help( description => 'X' ),
"X-ray (long description)",
"Test sarge slot help X (description)"
);
is( $tested->get_help( summary => 'X' ), "X-ray (summary)", "Test sarge slot help X (summary)" );
is( $root->has_element('daughter'), 0, "Non-existing element" );
is( $root->has_element('captain'), 1, "existing element" );
is( $root->has_element( name => 'captain', type => 'node' ), 1, "existing node element" );
is( $root->has_element( name => 'captain', type => 'leaf' ), 0, "non existing leaf element" );
ok( $root->is_element_available( name => 'captain' ), "test element" );
is( $root->get_element_property( property => 'level', element => 'hash_args' ),
'normal', "test (non) importance" );
is( $root->get_element_property( property => 'level', element => 'captain' ),
'important', "test importance" );
is(
$root->set_element_property(
property => 'level',
element => 'captain',
value => 'hidden'
),
'hidden',
"test importance"
);
is( $root->get_element_property( property => 'level', element => 'captain' ),
'hidden', "test hidden" );
is( $root->reset_element_property( property => 'level', element => 'captain' ),
'important', "test importance" );
map {
my $key_label = defined $_->[0] ? $_->[0] : 'undef';
is( $root->next_element( name => $_->[0] ), $_->[1], "test next_element ($key_label)" );
is( $root->previous_element( name => $_->[1] ), $_->[0], "test previous_element ($key_label)" )
unless ( defined $_->[0] and $_->[0] eq '' );
} (
[ undef, 'captain' ], [ '', 'captain' ],
[qw/captain array_args/], [qw/array_args hash_args/] );
memory_cycle_ok($model);
done_testing ;