The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# -*- 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;
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)' ],
    class => 'Config::Model::Node',

    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 ;