Config::Hierarchical - Hierarchical configuration container

 Config::Hierarchical - Hierarchical configuration container

  use Config::Hierarchical ;

  my $config = new Config::Hierarchical(); 

  # or

  my $config = new Config::Hierarchical
			(
			NAME                       => 'some_namespace',
			VERBOSE                    => 0,
			DISABLE_SILENT_OPTIONS     => 0,
			CATEGORY_NAMES             => ['<CLI>', '<PBS>', 'PARENT', 'LOCAL', 'CURRENT'],
			DEFAULT_CATEGORY           => 'CURRENT',

			WARN_FOR_EXPLICIT_CATEGORY => 0,

			GET_CATEGORIES => 
				{
				Inheritable => ['CLI', 'PBS', 'PARENT', 'CURRENT'],
				},

			INTERACTION =>
				{
				INFO  => \&sub,
				WARN  => \&sub,
				DIE   => \&sub,
				DEBUG => \&sub,
				},

			SET_VALIDATOR => \&my_set_validator,

			VALIDATORS =>
				[
				{
				CATEGORY_NAMES => ['CLI', 'CURRENT',] ,
				NAMES          => ['CC', 'LD'],
				VALIDATORS     => 
					{
					alphanumeric => \&alphanumeric,
					other_validator => \&other_validator,
					},
				},

				{
				CATEGORY_NAMES => ['CURRENT',] ,
				NAMES          => ['CC',],
				VALIDATORS     => {only_gcc => \&only_gcc,},
				}, 
				],

			INITIAL_VALUES =>
				[
				{
				CATEGORY       => 'PBS',
				ALIAS_CATEGORY => $pbs_config,
				HISTORY        => ....,
				COMMENT        => ....,
				},

				{CATEGORY => 'CLI', NAME => 'CC', VALUE => 1,},
				{CATEGORY => 'CLI', NAME => 'LD', VALUE => 2, LOCK => 1},

				{CATEGORY => 'CURRENT', NAME => 'CC', VALUE => 3, OVERRIDE => 1},
				{CATEGORY => 'CURRENT', NAME => 'AS', VALUE => 4,},
				{CATEGORY => 'CURRENT', NAME => 'VARIABLE_WITH_HISTORY', VALUE => $previous_value, HISTORY => $history },
				] ,

			LOCKED_CATEGORIES => ['CLI'],
			) ;

  $config->Set(NAME => 'CC', VALUE => 'gcc') ;
  $config->Set(NAME => 'CC', VALUE => 'gcc', CATEGORY => 'CLI') ;
  $config->Set(NAME => 'CC', VALUE => 'gcc', FORCE_LOCK => 1) ;
  $config->Set(NAME => 'CC', VALUE => 'gcc', SILENT_OVERRIDE => 1, COMMENT => 'we prefer gcc') ;

  $config->Exists(NAME => 'CC') ;

  $config->GetKeyValueTuples() ;

  $config->SetMultiple
	(
	{FORCE_LOCK => 1}
	{NAME => 'CC', VALUE => 'gcc', SILENT_OVERRIDE => 1},
	{NAME => 'LD', VALUE => 'ld'},
	) ;

  $config->Set(CC => 'gcc') ;

  $value = $config->Get(NAME => 'CC') ;
  $value = $config->Get(NAME => 'NON_EXISTANT', SILENT_NOT_EXISTS => 1) ;

  @values = $config->GetMultiple(@config_variables_names) ;
  @values = $config->GetMultiple({SILENT_NOT_EXISTS => 1}, @config_variables_names) ;

  $hash_ref = $config->GetHashRef() ; # no warnings

  $config->GetInheritable() ;

  $config->SetDisableSilentOptions(1) ;

  $config->LockCategories('PBS') ;
  $config->UnlockCategories('CLI', 'PBS') ;
  $config->IsCategoryLocked('PBS') ;

  $config->Lock(NAME => 'CC') ;
  $config->Unlock(NAME => 'CC', CATEGORY => 'CLI') ;
  $config->IsLocked(NAME => 'CC') ;

  $history = $config->GetHistory(NAME => 'CC') ;
  $dump = $config->GetDump() ;

  my $config = new Config::Hierarchical() ;

  my $config = new Config::Hierarchical(NAME => 'some_namespace', VERBOSE  => 1) ;

	$config->AddValidator
			(
			CATEGORY_NAMES => ['CLI'] ,
			NAMES          => ['CC', 'LD'],
			VALIDATORS     => {positive_value => \&PositiveValueValidator},
			) ;

  my $pbs_config = new Config::Hierarchical(...) ;

  my $config = new Config::Hierarchical
			(
			NAME                       => 'some_namespace',
			CATEGORY_NAMES             => ['<CLI>', '<PBS>', 'PARENT', 'LOCAL', 'CURRENT'],

			INITIAL_VALUES =>
				[
				{
				CATEGORY       => 'PBS',
				ALIAS_CATEGORY => $pbs_config,
				HISTORY        => ....,
				COMMENT        => ....,
				},
				{NAME => 'CC1', VALUE => 'gcc'},
				...
				] ,

			) ;

  my $config = new Config::Hierarchical() ;

  $config->Set(NAME => 'CC', VALUE => 'gcc') ;

  $config->Set
		(
		NAME => 'CC', VALUE => 'gcc',

		# options
		HISTORY         => $history,
		COMMENT         => 'we like gcc'
		CATEGORY        => 'CLI',
		VALIDATORS      => {positive_value => \&PositiveValueValidator,}
		FORCE_LOCK      => 1,
		LOCK            => 1,
		OVERRIDE        => 1,
		SILENT_OVERRIDE => 1,
		ATTRIBUTE       => 'some attribute',
		FILE            => 'some_file',
		LINE            => 1,

		CHECK_LOWER_LEVEL_CATEGORIES => 1,
		) ;

	my $config = new Config::Hierarchical() ;

	$config->Set(NAME => 'BASE',        VALUE => '/somewhere') ;
	$config->Set(NAME => 'MODULE',      VALUE => 'module') ;
	$config->Set(NAME => 'CONFIG_FILE', VALUE => 'my_config') ;

	$config->Set
		(
		NAME => 'PATH_TO_CONFIG_FILE', 
		VALUE => $config->Get(NAME => 'BASE') . '/'
			 . $config->Get(NAME => 'MODULE') . '/'
			 . $config->Get(NAME => 'CONFIG_FILE'),
		) ;

	$config->Set(NAME => 'PATH_TO_CONFIG_FILE', EVAL => q~ "$BASE/$MODULE/$CONFIG_FILE" ~) ;

  sub eval_engine
  {
  my ($config, $arguments) = @_ ;
  my $hash_ref = $config->GetHashRef() ;

  my $context = new Eval::Context
  		(
  		INSTALL_VARIABLES => 
  			[
  			map {["\$$_" => $hash_ref->{$_} ]} keys %$hash_ref
  			],
		INTERACTION  =>
			{
			EVAL_DIE => sub { my($self, $error) = @_ ; croak $error; },
			}
  		) ;

  my $value = eval {$context->eval(CODE => $arguments->{EVAL})} ;

  if($@)
  	{
  	$config->{INTERACTION}{DIE}->
  		(
  		"Error: Config::Hierarchical evaluating variable '$arguments->{NAME}' "
  		. "at $arguments->{FILE}:$arguments->{LINE}:\n\t". $@
  		) ;
  	}

  return $value ;
  }

  my $config = new Config::Hierarchical(EVALUATOR => \&eval_engine, ...) ;

	$config->SetAttribute(NAME => 'CC', ATTRIBUTE => 'attribute') ;

	# or directly in the 'Set' call

	$config->Set(NAME => 'CC', VALUE => 'CC', ATTRIBUTE => 'attribute') ;

	my ($attribute, $attribute_exists) = $config->GetAttribute(NAME => 'CC') ;

	my ($attribute, $attribute_exists) = $config->GetAttribute(NAME => 'CC') ;

  my $config = new Config::Hierarchical(INITIAL_VALUES => [{NAME => 'CC', VALUE => 'gcc'}]) ;

  my $cc = $config->Get(NAME => 'CC') ;
  my $ld = $config->Get(NAME => 'LD', SILENT_NOT_EXISTS => 1) ;

  $config->SetMultiple
	(
	{FORCE_LOCK => 1},

	[NAME => 'CC', VALUE => 'gcc', SILENT_OVERRIDE => 1],
	[NAME => 'LD', VALUE => 'ld'],
	) ;

  my $config = new Config::Hierarchical(INITIAL_VALUES => [{NAME => 'CC', VALUE => 'gcc'}]) ;

  my @values = $config->GetMultiple('CC') ;

  my @other_values = $config->GetMultiple
			(
			{SILENT_NOT_EXISTS => 1},
			'CC',
			'AR'
			) ;

  my @keys = $config->GetKeys() ;

	my $config_1 = new Config::Hierarchical(.....) ;

	my $config_2 = new Config::Hierarchical
					(
					NAME => 'config 2',

					CATEGORY_NAMES         => ['PARENT', 'CURRENT'],
					DEFAULT_CATEGORY       => 'CURRENT',

					INITIAL_VALUES =>
						[
						# Initializing a category from another config
						map
							({
								{
								NAME     => $_->{NAME},
								VALUE    => $_->{VALUE}, 
								CATEGORY => 'PARENT',
								LOCK     => 1,
								HISTORY  => $config_1->GetHistory(NAME => $_->{NAME}),
								}
							} $config_1->GetKeyValueTuples()),

						{NAME => 'CC', VALUE => 1,},
						]
					) ;

  my $hash_ref = $config->GetHashRef() ;

  $config->SetDisplayExplicitCategoryWarningOption(1) ;
  $config->SetDisplayExplicitCategoryWarningOption(0) ;

  $config->SetDisableSilentOptions(1) ;
  $config->SetDisableSilentOptions(0) ;

	$config->LockCategories('PARENT', 'OTHER') ;

  $config->Lock(NAME => 'CC') ;
  $config->Lock(NAME => 'CC', CATEGORY => 'PARENT') ;

	$config->UnlockCategories('PARENT', 'OTHER') ;

  $config->Unlock(NAME => 'CC') ;
  $config->Unlock(NAME => 'CC', CATEGORY => 'PARENT') ;

	$config->IsCategoryLocked('PARENT') ;

  $config->IsLocked(NAME => 'CC') ;
  $config->IsLocked(NAME => 'CC', CATEGORY => 'PARENT') ;

  $config->Exists(NAME => 'CC') ;

  $history = $config->GetHistory(NAME => 'CC') ;
  $history = $config->GetHistory(NAME => 'CC', CATEGORIES_TO_EXTRACT_FROM => ['PARENT']) ;

	my $config = new Config::Hierarchical
					(
					NAME => 'Test config',

					CATEGORY_NAMES         => ['PARENT', 'CURRENT'],
					DEFAULT_CATEGORY       => 'CURRENT',

					INITIAL_VALUES  =>
						[
						{NAME => 'CC', CATEGORY => 'PARENT', VALUE => 'parent'},
						] ,
					) ;

	$config->Set(NAME => 'CC', OVERRIDE => 1, VALUE => 'override value') ;

	my($value, $category) = $config->Get(NAME => 'CC',  GET_CATEGORY => 1) ;

	my $title = "'CC' = '$value' from category '$category':" ;
	print DumpTree($config->GetHistory(NAME=> 'CC'), $title, DISPLAY_ADDRESS => 0) ;

	'CC' = 'override value' from category 'CURRENT':
	|- 0 
	|  |- EVENT = . CREATE AND SET. value = 'parent', category = 'PARENT' at 'nadim2.pl:21', status = OK. 
	|  `- TIME = 0 
	`- 1 
	   |- EVENT = value = CREATE AND SET, OVERRIDE. 'override value', category = 'CURRENT' at 'nadim2.pl:34', status =
	   |  Overriding 'PARENT::CC' (existed, value was different).OK. 
	   `- TIME = 1 

	my($value, $category) = $config->Get(NAME => 'CC', GET_CATEGORY => 1, CATEGORIES_TO_EXTRACT_FROM => ['PARENT']) ;

	my $title = "'CC' = '$value' from category '$category':" ;
	print DumpTree($config->GetHistory(NAME=> 'CC', CATEGORIES_TO_EXTRACT_FROM => ['PARENT']), $title, DISPLAY_ADDRESS => 0) ;

	'CC' = 'parent' from category 'PARENT':
	`- 0 
	   |- EVENT = value = CREATE AND SET. 'parent', category = 'PARENT' at 'nadim2.pl:21', status = OK. 
	   `- TIME = 0 

	my $config3 = new Config::Hierarchical
					(
					NAME => 'config3',
					...
					INITIAL_VALUES  =>
						[
						{
						COMMENT => "history and value from category 2",	
						NAME => 'CC', CATEGORY => 'PARENT', VALUE => $value2,
						HISTORY => $history2,
						},
						] ,
					...
					) ;

	my($value3, $category3) = $config3->Get(NAME => 'CC',  GET_CATEGORY => 1) ;
	my $title3 = "'CC' = '$value3' from category '$category3':" ;
	my $history3 = $config3->GetHistory(NAME=> 'CC') ;
	print DumpTree($history3, $title3, DISPLAY_ADDRESS => 0) ;

	'CC' = '3' from category 'PARENT':
	|- 0
	|  |- COMMENT = history and value from config 2
	|  |- EVENT = CREATE, SET HISTORY AND SET. value = '3', category = 'PARENT' at 'history.pl:56', status = OK.
	|  |- HISTORY
	|  |  |- 0
	...

	my $config0 = (...) ;
	my $config1 = (...) ;
	my $config2 = new Config::Hierarchical
					(
					...
					INITIAL_VALUES =>
						[
						{
						CATEGORY       => 'PBS',
						ALIAS_CATEGORY => $config1,
						HISTORY        => ....,
						COMMENT        => ....,
						},
					...
					) ;

	...
	print DumpTree $config_3->GetHistory( NAME => 'CC1'), 'CC1', DISPLAY_ADDRESS => 0;

	CC1
	|- 0
	|  |- HISTORY FROM ALIASED CATEGORY 'config 1'
	|  |  |- 0
	|  |  |  |- HISTORY FROM ALIASED CATEGORY 'config 0'
	|  |  |  |  `- 0
	|  |  |  |     |- EVENT = CREATE AND SET. value = '1', category = 'CURRENT' at 'nadim.pl:21', status = OK.
	|  |  |  |     `- TIME = 0
	|  |  |  `- TIME = 2
	|  |  |- 1
	|  |  |  |- EVENT = CREATE AND SET. value = '1', category = 'A' at 'nadim.pl:33', status = OK.
	|  |  |  `- TIME = 3
	|  |  `- 2
	|  |     |- EVENT = Set. value = '1.1', category = 'A' at 'nadim.pl:50', status = OK.
	|  |     `- TIME = 6
	|  `- TIME = 3
	|- 1
	|  |- EVENT = CREATE AND SET, OVERRIDE. value = 'A', category = 'A' at 'nadim.pl:64', status = OK.
	|  `- TIME = 4
	`- 2
	   |- EVENT = SET, OVERRIDE. value = 'A2', category = 'A' at 'nadim.pl:65', status = OK.
	   `- TIME = 5

	sub Compact
	{
	my ($s, $level, $path, $keys, $setup, $arg) = @_ ;

	if('ARRAY' eq ref $s)
		{
		my ($index, @replacement, @keys) = (0) ;

		for my $entry( @$s)
			{
			if(exists $entry->{EVENT})
				{
				push @replacement, $entry->{EVENT} ; #. 'time: ' . $entry->{TIME};
				push@keys, $index++ ;
				}
			else
				{
				my ($aliased_history_name) = grep {$_ ne 'TIME'} keys %$entry ;

				push @replacement, $entry->{$aliased_history_name} ;
				push@keys, [$index, "$index = $aliased_history_name"] ;
				$index++ ;
				}
			}

		return('ARRAY', \@replacement, @keys) ;
		}
	}

	print DumpTree $config_2->GetHistory( NAME => 'CC1'), 'CC1', DISPLAY_ADDRESS => 0, FILTER => \&Compact ;

	CC1
	|- 0 = HISTORY FROM ALIASED CATEGORY 'config 1'
	|  |- 0 = HISTORY FROM ALIASED CATEGORY 'config 0'
	|  |  `- 0 = CREATE AND SET. value = '1', category = 'CURRENT' at 'nadim.pl:21', status = OK.
	|  |- 1 = CREATE AND SET. value =  '1', category = 'A' at 'nadim.pl:33', status = OK.
	|  `- 2 = SET. value = '1.1', category = 'A' at 'nadim.pl:50', status = OK.
	|- 1 = CREATE AND SET, OVERRIDE. value = 'A', category = 'A' at 'nadim.pl:64', status = OK.
	`- 2 = SET, OVERRIDE. value = 'A2', category = 'A' at 'nadim.pl:65', status = OK.

  $dump = $config->GetHistoryDump(NAME => 'CC') ;

  $dump = $config->GetHistoryDump(CATEGORIES_TO_EXTRACT_FROM => ['A', 'B'], NAME => 'CC', DATA_TREEDUMPER_OPTIONS => []) ;

	my $config = new Config::Hierarchical( LOG_ACCESS => 1, ...) ;

	my $value = $config->Get(NAME => 'A') ;
	$value    = $config->Get(NAME => 'B') ;
	$value    = $config->Get(NAME => 'A', CATEGORIES_TO_EXTRACT_FROM => ['PARENT']) ;

	my $access_log = $config->GetAccessLog() ;

	access log:
	|- 0 
	|  |- FILE = test.pl 
	|  |- LINE = 28 
	|  `- NAME = A 
	|- 1 
	|  |- FILE = test.pl 
	|  |- LINE = 29 
	|  `- NAME = B 
	`- 2 
	   |- CATEGORIES_TO_EXTRACT_FROM 
	   |  `- 0 = PARENT 
	   |- FILE = test.pl 
	   |- LINE = 30 
	   `- NAME = A 

  $dump = $config->GetDump(@data_treedumper_options) ;
  $dump = $config->GetDump(@data_treedumper_options) ;

	Khemir Nadim ibn Hamouda
	CPAN ID: NKH
	mailto:nadim@khemir.net

    perldoc Config::Hierarchical

package Config::Hierarchical ;
use base Exporter ;

use strict;
use warnings ;

BEGIN 
{
use Exporter ();

use vars qw ($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);

$VERSION     = 0.11;
@EXPORT_OK   = qw ();
%EXPORT_TAGS = ();
}

#-------------------------------------------------------------------------------

use Carp ;
use Data::Compare;
use Sub::Install;

use English qw( -no_match_vars ) ;

use Readonly ;
Readonly my $EMPTY_STRING => q{} ;

Readonly my $VALID_OPTIONS =>
	{ 
	map{$_ => 1}
		qw(
			NAME VALUE 
			EVAL EVALUATOR
			HISTORY ATTRIBUTE
			COMMENT
			CATEGORY CATEGORIES_TO_EXTRACT_FROM 
			GET_CATEGORY WARN_FOR_EXPLICIT_CATEGORY
			SET_VALIDATOR
			VALIDATORS
			CHECK_LOWER_LEVEL_CATEGORIES
			LOCK FORCE_LOCK
			OVERRIDE
			SILENT_NOT_EXISTS SILENT_OVERRIDE
			VERBOSE
			FILE LINE 
			ALIAS_CATEGORY
			DATA_TREEDUMPER_OPTIONS
			)
	} ;

Readonly my $CONSTRUCTOR_VALID_OPTIONS =>
	{ 
	map{$_ => 1}
		qw(
			LOG_ACCESS
			INITIAL_VALUES
			CATEGORY_NAMES
			DEFAULT_CATEGORY
			INTERACTION
			DISABLE_SILENT_OPTIONS
			LOCKED_CATEGORIES
			GET_CATEGORIES
			)
	} ;

#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------

sub new
{

my ($invocant, @setup_data) = @_ ;

my $class = ref($invocant) || $invocant ;

confess 'Invalid constructor call!' unless defined $class ;

my $self = {} ;

my ($package, $file_name, $line) = caller() ;
bless $self, $class ;

$self->Setup($package, $file_name, $line, @setup_data) ;

return($self) ;
}

#-------------------------------------------------------------------------------

sub GetInformation
{

my ($self) = @_ ;

return($self->{NAME}, "$self->{FILE}:$self->{LINE}") ;
}

#-------------------------------------------------------------------------------

sub Setup
{

my ($self, $package, $file_name, $line, @setup_data) = @_ ;

SetInteractionDefault($self) ;
$self->CheckOptionNames
	(
	{ %{$VALID_OPTIONS}, %{$CONSTRUCTOR_VALID_OPTIONS}}, 
	@setup_data,
	NAME => 'Anonymous eval context', FILE => $file_name, LINE => $line,
	) ;

%{$self} = 
	(
	NAME                   => 'Anonymous',
	CATEGORY_NAMES         => ['CURRENT'],
	DISABLE_SILENT_OPTIONS => 0,
	FILE                   => $file_name,
	LINE                   => $line,
	
	@setup_data,
	
	CATEGORIES             => {},
	TIME_STAMP             => 0,
	) ;

SetInteractionDefault($self) ;

my $location = "$self->{FILE}:$self->{LINE}" ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}('Creating ' . ref($self) . " '$self->{NAME}' at $location.\n") ;
	}

$self->SetupCategories($location) ;

if(exists $self->{VALIDATORS})
	{
	$self->AddValidators($self->{VALIDATORS}, $location) ;
	delete $self->{VALIDATORS} ;
	}

if(exists $self->{SET_VALIDATOR})
	{
	if('CODE' ne ref $self->{SET_VALIDATOR})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid 'SET_VALIDATOR' definition, expecting a sub reference at '$location'!") ;
		}
	}

if(exists $self->{EVALUATOR})
	{
	if('CODE' ne ref $self->{EVALUATOR})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid 'EVALUATOR' definition, expecting a sub reference at '$location'!") ;
		}
	}

# temporarely remove the locked categories till we have handled INITIAL_VALUES
my $category_locks ;

if(exists $self->{LOCKED_CATEGORIES})
	{
	if('ARRAY' ne ref $self->{LOCKED_CATEGORIES})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid 'LOCKED_CATEGORIES' at '$location'!") ;
		}
		
	$category_locks = $self->{LOCKED_CATEGORIES}  ;
	delete $self->{LOCKED_CATEGORIES} ;
	}
	
if(exists $self->{INITIAL_VALUES})
	{
	for my $element_data (@{$self->{INITIAL_VALUES}})
		{
		if(exists $element_data->{ALIAS_CATEGORY})
			{
			$self->SetCategoryAlias(FILE => $self->{FILE}, LINE => $self->{LINE}, %{$element_data}) ;
			}
		else
			{
			$self->Set(FILE => $self->{FILE}, LINE => $self->{LINE}, %{$element_data}) ;
			}
		}
		
	delete $self->{INITIAL_VALUES} ;
	
	if(defined $category_locks)
		{
		#TODO:  should be a category attribute not a config attribute
		$self->{LOCKED_CATEGORIES}  = { map {$_ => 1} @{$category_locks} } ;
		}
	}
	
CreateCustomGetFunctions(keys %{ $self->{GET_CATEGORIES} }) if exists $self->{GET_CATEGORIES} ;

return(1) ;
}

#-------------------------------------------------------------------------------

sub SetInteractionDefault
{
	

my ($interaction_container) = @_ ;

$interaction_container->{INTERACTION}{INFO} ||= sub {print @_} ;  ## no critic (InputOutput::RequireCheckedSyscalls)
$interaction_container->{INTERACTION}{WARN} ||= \&Carp::carp ;
$interaction_container->{INTERACTION}{DIE}  ||= \&Carp::confess ;

return ;
}

#-------------------------------------------------------------------------------

sub SetupCategories
{

my ($self, $location) = @_ ;

# find the protected categories and removes the brackets from the name
$self->{PROTECTED_CATEGORIES} = { map{ if(/^<(.*)>$/xm) {$1 => 1} else {} } @{ $self->{CATEGORY_NAMES} } } ;  ## no critic (BuiltinFunctions::ProhibitComplexMappings)

my @seen_categories ;
for my $name (@{$self->{CATEGORY_NAMES}})
	{
	if($name =~ /^<(.*)>$/xm)
		{
		my $name_without_brackets = $1 ;
		
		if($name_without_brackets =~ /<|>/xm)
			{
			$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category name '$name_without_brackets' at '$location'!") ;
			}
		else
			{
			$name = $1 ;
			}
		}
		
	# create a list of higher level categories to avoid computing it at run time
	$self->{REVERSED_HIGHER_LEVEL_CATEGORIES}{$name} = [reverse @seen_categories] ;
	push @seen_categories, $name ;
	}

$self->{VALID_CATEGORIES} = { map{$_ => 1} @{$self->{CATEGORY_NAMES}}} ;

# set and check the default category
if(1 == @{$self->{CATEGORY_NAMES}})
	{
	$self->{DEFAULT_CATEGORY} = @{$self->{CATEGORY_NAMES}}[0] ;
	}
else
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: No default category at '$location'!") unless exists $self->{DEFAULT_CATEGORY} ;
	}

unless(exists $self->{VALID_CATEGORIES}{$self->{DEFAULT_CATEGORY}})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid default category '$self->{DEFAULT_CATEGORY}' at '$location'!") ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub AddValidator
{
	

my ($self,  %setup) = @_ ;

my ($package, $file_name, $line) = caller() ;
my $location = "$self->{FILE}:$self->{LINE}" ;

$self->AddValidators([{%setup}], $location) ;

return(1) ;
}

#-------------------------------------------------------------------------------

sub AddValidators
{
	

my ($self,  $validators, $location) = @_ ;

for my $validator_definition (@{$validators})
	{
	if
		(
		'HASH' ne ref $validator_definition
		|| 3 != keys %{$validator_definition}
		
		|| ! exists $validator_definition->{CATEGORY_NAMES}
		|| 'ARRAY' ne ref $validator_definition->{CATEGORY_NAMES}
		
		|| ! exists $validator_definition->{NAMES}
		|| 'ARRAY' ne ref $validator_definition->{NAMES}
		
		|| ! exists $validator_definition->{VALIDATORS}
		|| 'HASH' ne ref $validator_definition->{VALIDATORS}
		)
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid validator definition at '$location'!")  ;
		}
		
	for my $category_name (@{$validator_definition->{CATEGORY_NAMES}})
		{
		unless(exists $self->{VALID_CATEGORIES}{$category_name})
			{
			$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category_name' in validator setup at '$location'!") ;
			}
			
		for my $variable_name (@{$validator_definition->{NAMES}})
			{
			$self->AddVariableValidator($category_name, $variable_name, $validator_definition, $location) ;
			}
		}
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub AddVariableValidator
{
	

my ($self, $category_name, $variable_name, $validator_definition, $location) = @_ ;

for my $validator (keys %{$validator_definition->{VALIDATORS}})
	{
	my ($config_variable_value_exists, $config_variable_value) ;

	if(exists $self->{ALIASED_CATEGORIES}{$category_name})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't Add validator '$validator' to aliased category '${category_name}'at '$location'.\n") ;
		}
		
	if($self->{VERBOSE})
		{
		$self->{INTERACTION}{INFO}->("$self->{NAME}: Adding validator '$validator' defined at '$location' to '${category_name}::$variable_name'.\n") ;
		}
		
	if(exists $self->{CATEGORIES}{$category_name}{$variable_name})
		{
		if(exists $self->{CATEGORIES}{$category_name}{$variable_name}{VALUE})
			{
			$config_variable_value_exists++ ;
			$config_variable_value = $self->{CATEGORIES}{$category_name}{$variable_name}{VALUE} ;
			}
		}
	else
		{
		$self->{CATEGORIES}{$category_name}{$variable_name} = {} ;
		}

	my $config_variable = $self->{CATEGORIES}{$category_name}{$variable_name} ;

	if('CODE' ne ref $validator_definition->{VALIDATORS}{$validator})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid validator '$validator' (must be a code reference) at '$location'!") ;
		}
		
	if(exists $config_variable->{VALIDATORS}{$validator})
		{
		$self->{INTERACTION}{WARN}->
			(
			  "$self->{NAME}: Overriding variable '$variable_name' validator '$validator' "
			. '(originaly defined at ' . $config_variable->{VALIDATORS}{$validator}{ORIGIN} . ') '
			. "at '$location'!"
			) ;
		}
		
	$config_variable->{VALIDATORS}{$validator}{ORIGIN} = $location ;
	$config_variable->{VALIDATORS}{$validator}{SUB} = $validator_definition->{VALIDATORS}{$validator} ;

	if($config_variable_value_exists)
		{
		# check already existing value
		
		unless($validator_definition->{VALIDATORS}{$validator}->($config_variable_value))
			{
			$self->{INTERACTION}{DIE}->
				("$self->{NAME}: Invalid value '$config_variable_value' for variable '$variable_name'. Validator '$validator' defined at '$location'.\n") ;
			}
		}
	}

return(1) ;
}

#-------------------------------------------------------------------------------

sub SetCategoryAlias
{
	

my ($self, @options) = @_ ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

my $location = "$options{FILE}:$options{LINE}" ;
my $category = $options{CATEGORY} ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category' at at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid 'NAME' at '$location'!") if defined $options{NAME} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid 'VALUE' at '$location'!") if defined $options{VALUE} ;

# category must not have been set or aliased
if(exists $self->{CATEGORIES}{$category})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't alias a category that's is already set at '$location'!") ;
	}

# inform of action if option set
if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: SetCategoryAlias called for category '$category' at '$location'.\n") ;
	}

use Config::Hierarchical::Tie::ReadOnly ;

my %alias_hash ;
tie %alias_hash, 'Config::Hierarchical::Tie::ReadOnly', $options{ALIAS_CATEGORY} ; ## no critic (ProhibitTies)

# first check we can do this
for($options{ALIAS_CATEGORY}->GetKeyValueTuples())
	{
	$self->Set
			(
			CATEGORY => $category,
			NAME => $_->{NAME},
			VALUE => $_->{VALUE},
			CHECK_LOWER_LEVEL_CATEGORIES => $options{CHECK_LOWER_LEVEL_CATEGORIES},
			FILE => $options{FILE},
			LINE => $options{LINE},
			)	
	}

#override everything
$self->{CATEGORIES}{$category} = \%alias_hash ;

$self->{ALIASED_CATEGORIES}{$category} = {} ;
$self->{ALIASED_CATEGORIES}{$category}{COMMENT} =  $options{COMMENT} if exists $options{COMMENT} ;
$self->{ALIASED_CATEGORIES}{$category}{HISTORY} =  {TIME => $self->{TIME_STAMP}, EVENT => $options{HISTORY}} if exists $options{HISTORY} ;
$self->{ALIASED_CATEGORIES}{$category}{TIME_STAMP} =  $self->{TIME_STAMP}++ ;

$self->{LOCKED_CATEGORIES}{$category}++ ;

return(1) ;
}

#-------------------------------------------------------------------------------

sub CreateCustomGetFunctions
{
	

my (@function_names) = @_ ;

for my $function_name (@function_names)
	{
	my $get_code = sub 
			{
			my($self, @arguments) = @_ ;
			
			return
				(
				$self->Get(@arguments, CATEGORIES_TO_EXTRACT_FROM => $self->{GET_CATEGORIES}{$function_name})
				) ;
			} ;
		
	Sub::Install::install_sub
		({
		code => $get_code,
		as   => 'Get' . $function_name
		});
		
	my $get_hash_ref_code = sub 
			{
			my($self, @arguments) = @_ ;
			
			return
				(
				$self->GetHashRef(CATEGORIES_TO_EXTRACT_FROM => $self->{GET_CATEGORIES}{$function_name})
				) ;
			} ;
		
	Sub::Install::install_sub
		({
		code => $get_hash_ref_code ,
		as   => 'Get' . $function_name . 'HashRef'
		});
	}

return(1) ;
}

#-------------------------------------------------------------------------------

sub CheckOptionNames
{

my ($self, $valid_options, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

for my $option_name (keys %options)
	{
	unless(exists $valid_options->{$option_name})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid Option '$option_name' at '$self->{FILE}:$self->{LINE}'!")  ;
		}
	}

if
	(
	   (defined $options{FILE} && ! defined $options{LINE})
	|| (!defined $options{FILE} && defined $options{LINE})
	)
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Incomplete option FILE::LINE!") ;
	}

return(1) ;
}

#-------------------------------------------------------------------------------

sub Set
{

my ($self, @options) = @_ ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

if(exists $options{CATEGORY})
	{
	if($self->{WARN_FOR_EXPLICIT_CATEGORY})
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: Setting '$options{NAME}' using explicit category at '$location'!\n") ;
		}
	}
else
	{
	$options{CATEGORY} = $self->{DEFAULT_CATEGORY} ;
	}

#~ use Data::TreeDumper ;
#~ print DumpTree {Options => \%options, Self => $self} ;

$self->CheckSetArguments(\%options, $location) ;

my $value_to_display = defined $options{VALUE} ? "'$options{VALUE}'" : 'undef' ;

# inform of action if option set
if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Setting '$options{CATEGORY}::$options{NAME}' to $value_to_display at '$location'.\n") ;
	}

# run debug hook if any
if(defined $self->{INTERACTION}{DEBUG})
	{
	$self->{INTERACTION}{DEBUG}->
		(
		"Setting '$options{CATEGORY}::$options{NAME}' to $value_to_display at '$location'.",
		$self,
		\%options,
		) ;
	}
	
if(exists $self->{LOCKED_CATEGORIES}{$options{CATEGORY}})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Variable '$options{CATEGORY}::$options{NAME}', category '$options{CATEGORY}' was locked at '$location'.\n") ;
	}

if
	(
	      exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}}
	&& defined $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}}{OVERRIDE}
	&& ! exists $options{OVERRIDE}
	)
	{
	my $override_location = $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}}{OVERRIDE} ;
	
	$self->{INTERACTION}{WARN}->("$self->{NAME}: '$options{NAME}' is of OVERRIDE type set at '$override_location' at '$location'!\n") ;
	$options{OVERRIDE} = '1 (due to previous override)' ;
	}
	
my ($high_priority_check_set_status, $high_priority_check_warnings) = $self->CheckHigherPriorityCategories(\%options, $location) ;
my ($low_priority_check_set_status, $low_priority_check_warnings) = ($EMPTY_STRING, $EMPTY_STRING) ;

if($self->{CHECK_LOWER_LEVEL_CATEGORIES} || $options{CHECK_LOWER_LEVEL_CATEGORIES})
	{
	($low_priority_check_set_status, $low_priority_check_warnings) = $self->CheckLowerPriorityCategories(\%options, $location) ;
	}

my $warnings = $high_priority_check_warnings . $low_priority_check_warnings ;
my $set_status = $high_priority_check_set_status . $low_priority_check_set_status ;

if($warnings ne $EMPTY_STRING)
	{
	$self->{INTERACTION}{WARN}->
		(
		"$self->{NAME}: Setting '$options{CATEGORY}::$options{NAME}' at '$location':\n$warnings" 
		) ;
	}

$self->CheckAndSetVariable(\%options, $set_status, $location) ;

return(1) ;
}

#-------------------------------------------------------------------------------

sub CheckSetArguments
{

my ($self, $options, $location) = @_ ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$options->{CATEGORY}' at at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options->{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options->{NAME} ;

if(exists $options->{VALUE} && exists $options->{EVAL})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't have 'VALUE' and 'EVAL' at '$location'!") ;
	}

if(! exists $options->{VALUE} && ! exists $options->{EVAL})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing 'VALUE' or 'EVAL' at '$location'!") ;
	}

if(exists $options->{EVAL})
	{
	if(exists $self->{EVALUATOR})
		{
		$options->{VALUE} = $self->{EVALUATOR}->($self, $options) ;
		}
	else
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: No 'EVALUATOR' defined at '$location'!") ;
		}
	}

if(exists $options->{SET_VALIDATOR})
	{
	$options->{SET_VALIDATOR}->($self, $options, $location) 
	}
elsif(exists $self->{SET_VALIDATOR})
	{
	$self->{SET_VALIDATOR}->($self, $options, $location) ;
	}

if(exists $self->{ALIASED_CATEGORIES}{$options->{CATEGORY}})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't set aliased category (read only) at '$location'!")  ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub CheckHigherPriorityCategories
{

my ($self, $options, $location) = @_ ;

my (@reversed_higher_priority_categories) = @{$self->{REVERSED_HIGHER_LEVEL_CATEGORIES}{$options->{CATEGORY}}} ;

my ($warnings, $set_status) = ($EMPTY_STRING, $EMPTY_STRING) ;

my $crossed_protected_category = 0 ;

for my $category (@reversed_higher_priority_categories)
	{
	# categories are travesed in reverse order as it is not allowed to override across a protected category
	# check all higher priority categories and warn of override
	
	if((! $crossed_protected_category) && $options->{OVERRIDE})
		{
		if(exists $self->{PROTECTED_CATEGORIES}{$category})
			{
			my $message = "'<${category}>::$options->{NAME}' takes precedence." ;
			$set_status .=  $message ;
			
			my ($name_exists_in_category, $value_exists_in_category, $value_in_category) 
				= $self->CheckVariableInCategory($category, $options->{NAME}) ;
				
			if($name_exists_in_category && $value_exists_in_category)
				{
				if(!Compare($value_in_category, $options->{VALUE}))
					{
					$warnings   .= "\t$message\n" ;
					}
					
				last; # can't override over a protected category
				}
			else
				{
				$crossed_protected_category++ ; # keep looking for a category that can take precedence
				}
			}
		else
			{
			my ($override_set_status, $override_warnings)
				 = $self->OverrideVariable
					(
					$category,
					$options->{NAME},
					$options->{VALUE},
					$options->{CATEGORY},
					$location,
					$options->{SILENT_OVERRIDE}
					) ;
					
			$set_status .=	$override_set_status ;
			$warnings .= $override_warnings ;
			}
		}
	else
		{
		my $message = exists $self->{PROTECTED_CATEGORIES}{$category} ?
						"'<${category}>::$options->{NAME}' takes precedence ." :
						"'${category}::$options->{NAME}' takes precedence ." ;
		
		$set_status .=  $message ;
		
		my ($name_exists_in_category, $value_exists_in_category, $value_in_category) 
			= $self->CheckVariableInCategory($category, $options->{NAME}) ;
		
		if($name_exists_in_category && $value_exists_in_category)
			{
			if(!Compare($value_in_category, $options->{VALUE}))
				{
				$warnings   .= "\t$message\n" ;
				}
				
			last if(exists $self->{PROTECTED_CATEGORIES}{$category}) ;
			}
		}
	}

return($set_status, $warnings) ;
}

sub CheckVariableInCategory
{

my ($self, $category, $name) = @_ ;
my ($name_exists, $value_exists, $value, $overridden) ;

if(exists $self->{CATEGORIES}{$category} && exists $self->{CATEGORIES}{$category}{$name})
	{
	$name_exists++ ;
	
	if(exists $self->{ALIASED_CATEGORIES}{$category})
		{
		$value_exists = 1 ;
		$value = $self->{CATEGORIES}{$category}{$name} ;
		
		if(exists $self->{ALIASED_CATEGORIES}{$category}{$name}{OVERRIDDEN})
			{
			$overridden = $self->{ALIASED_CATEGORIES}{$category}{$name}{OVERRIDDEN}
			}
		}
	else
		{
		if(exists $self->{CATEGORIES}{$category}{$name}{VALUE})
			{
			$value_exists = 1 ;
			$value = $self->{CATEGORIES}{$category}{$name}{VALUE} ;
			
			if(exists $self->{CATEGORIES}{$category}{$name}{OVERRIDDEN})
				{
				$overridden = $self->{CATEGORIES}{$category}{$name}{OVERRIDDEN} ;
				}
			}
		}
	}

return ($name_exists, $value_exists, $value, $overridden)  ;
}

#-------------------------------------------------------------------------------

sub OverrideVariable ## no critic (Subroutines::ProhibitManyArgs)
{
	

my ($self, $category, $variable_name, $value, $overriding_category, $location, $silent_override) = @_ ;

my ($set_status, $warnings) = ($EMPTY_STRING, $EMPTY_STRING) ;

my $override_message = "Overriding '${category}::$variable_name'" ;

my ($name_exists_in_category, $value_exists_in_category, $value_in_category) 
	= $self->CheckVariableInCategory($category, $variable_name) ;

if($name_exists_in_category && $value_exists_in_category)
	{
	if(!Compare($value_in_category, $value))
		{
		my $no_silent_override = (! ($silent_override || $self->{DISABLE_SILENT_OPTIONS})) ;
		
		$warnings   .= "\t$override_message\n" if($no_silent_override) ;
		$set_status .= "$override_message (existed, value was different)." ;
		}
	else
		{
		$set_status .= "$override_message (existed, value was equal)." ;
		}
	}
else
	{
	$set_status .= "$override_message (didn't exist)" ;
	}
	
#last to avoid autovivication
if(exists $self->{ALIASED_CATEGORIES}{$category})
	{
	# override localy, aliased config is not modified
	push @{ $self->{ALIASED_CATEGORIES}{$category}{$variable_name}{OVERRIDDEN} }, {CATEGORY => $overriding_category, AT => $location} ;
	}
else
	{
	push @{ $self->{CATEGORIES}{$category}{$variable_name}{OVERRIDDEN} }, {CATEGORY => $overriding_category, AT => $location} ;
	}

return($set_status, $warnings) ;
}

#-------------------------------------------------------------------------------

sub CheckLowerPriorityCategories
{

my ($self, $options, $location) = @_ ;

my ($warnings, $set_status, @lower_priority_categories) = ($EMPTY_STRING, $EMPTY_STRING) ;

for my $category (reverse @{$self->{CATEGORY_NAMES}})
	{
	if($category eq $options->{CATEGORY})
		{
		last ;
		}
	else
		{
		push @lower_priority_categories, $category ;
		}
	}
	
for my $category (reverse @lower_priority_categories)
	{
	my ($name_exists_in_category, $value_exists_in_category, $value_in_category) 
		= $self->CheckVariableInCategory($category, $options->{NAME}) ;
	
	if
		(
		   $name_exists_in_category 
		&& !Compare($value_in_category, $options->{VALUE})
		)
		{
		my $message = exists $self->{PROTECTED_CATEGORIES}{$category} ?
					"Takes Precedence over lower category '<${category}>::$options->{NAME}'" :
					"Takes Precedence over lower category '${category}::$options->{NAME}'" ;
			
		$set_status .=  $message ;
		$warnings   .= "\t$message\n" ;
		}
	}
	
return($set_status, $warnings) ;
}

#-------------------------------------------------------------------------------

sub CheckAndSetVariable
{ ## no critic (ProhibitExcessComplexity)

my($self, $options, $set_status, $location) = @_ ;

my $config_variable_exists = exists $self->{CATEGORIES}{$options->{CATEGORY}}{$options->{NAME}} ;

my $action = $EMPTY_STRING ;
my $config_variable ;

$self->Validate($options, $set_status, $location, $config_variable_exists)  ;

unless($config_variable_exists)
	{
	# didn't exist before this call
	
	$config_variable = $self->{CATEGORIES}{$options->{CATEGORY}}{$options->{NAME}} = {} ;

	$action .=  'CREATE' ;
	$action .=  exists $options->{HISTORY} ? ', SET HISTORY' : $EMPTY_STRING ;
	$action .=  exists $options->{ATTRIBUTE} ? ', SET ATTRIBUTE' : $EMPTY_STRING ;
	$action .= ' AND SET' ;
	
	$set_status .= 'OK.' ;
	}
else
	{
	$action = 'SET' ;
	$action .=  exists $options->{ATTRIBUTE} ? ', SET ATTRIBUTE' : $EMPTY_STRING ;

	if(exists $options->{HISTORY})
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't add history for already existing variable '$options->{CATEGORY}::$options->{NAME}' at '$location'.\n") ;
		}
		
	$config_variable = $self->{CATEGORIES}{$options->{CATEGORY}}{$options->{NAME}} ;
	 
	if(exists $config_variable->{OVERRIDDEN})
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: Variable '$options->{CATEGORY}::$options->{NAME}' was overridden at '$config_variable->{OVERRIDDEN}'. The new value defined at '$location' might not be used.\n") ;
		}
		
	if(! Compare($config_variable->{VALUE}, $options->{VALUE}))
		{
		# not the same value
		
		unless(exists $config_variable->{LOCKED})
			{
			#~ Not locked, set
			$set_status .= 'OK.' ;
			}
		else
			{
			if($options->{FORCE_LOCK})
				{
				$set_status .= 'OK, forced lock.' ;
				$self->{INTERACTION}{WARN}->("$self->{NAME}: Forcing locked variable '$options->{CATEGORY}::$options->{NAME}' at '$location'.\n") ;
				}
			else 
				{
				$self->{INTERACTION}{DIE}->("$self->{NAME}: Variable '$options->{CATEGORY}::$options->{NAME}' was locked and couldn't be set at '$location'.\n") ;
				}
			}
		}
	else
		{
		$set_status .= 'OK, same value.' ;
		}
	}

$config_variable->{VALUE} = $options->{VALUE} ;
$config_variable->{OVERRIDE} = $location if $options->{OVERRIDE} ;
$config_variable->{ATTRIBUTE} = $options->{ATTRIBUTE} if $options->{ATTRIBUTE} ;

#~ set lock state
my $lock = $EMPTY_STRING ;
my $force_lock = $options->{FORCE_LOCK} ? 'FORCE_LOCK, ' : $EMPTY_STRING ;

if(exists $options->{LOCK})
	{
	if($options->{LOCK})
		{
		$lock = 'LOCK(1), ' ;
		$config_variable->{LOCKED} = $location  ;
		}
	else
		{
		$lock = 'LOCK(0), ' ;
		delete $config_variable->{LOCKED} ;
		}
	}
	
# update history

my $override = exists $options->{OVERRIDE} ? 'OVERRIDE, ' : $EMPTY_STRING ;

my $value_to_display = defined $options->{VALUE} ? "'$options->{VALUE}'" : 'undef' ;
my $history = "$action. value = $value_to_display, ${override}${force_lock}${lock}category = '$options->{CATEGORY}' at '$options->{FILE}:$options->{LINE}', status = $set_status" ;

my $history_data = {TIME => $self->{TIME_STAMP}, EVENT => $history} ;
$history_data->{HISTORY} = $options->{HISTORY} if exists $options->{HISTORY} ;
$history_data->{COMMENT} = $options->{COMMENT} if exists $options->{COMMENT} ;

push @{$config_variable->{HISTORY}}, $history_data ;

$self->{TIME_STAMP}++ ;

return(1) ;
}

#-------------------------------------------------------------------------------

sub SetAttribute
{

my ($self, @options) = @_ ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

if(exists $options{CATEGORY})
	{
	if($self->{WARN_FOR_EXPLICIT_CATEGORY})
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: Setting '$options{NAME}' using explicit category at '$location'!\n") ;
		}
	}
else
	{
	$options{CATEGORY} = $self->{DEFAULT_CATEGORY} ;
	}

#~ use Data::TreeDumper ;
#~ print DumpTree {Options => \%options, Self => $self} ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$options{CATEGORY}' at at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing value at '$location'!") unless exists $options{VALUE} ;

my $value_to_display = defined $options{VALUE} ? "'$options{VALUE}'" : 'undef' ;

if(exists $self->{ALIASED_CATEGORIES}{$options{CATEGORY}})
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't set aliased category attribute (read only) at '$location'!")  ;
	}

# inform of action if option set
if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: SetAttribute for '$options{CATEGORY}::$options{NAME}' to $value_to_display at '$location'.\n") ;
	}

if(exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}})
	{
	my $config_variable = $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}} ;
	$config_variable->{ATTRIBUTE} = $options{VALUE};	
	
	my $history = "SET_ATTRIBUTE. category = '$options{CATEGORY}', value = $value_to_display at '$location', status = OK." ;
	push @{$config_variable->{HISTORY}}, {TIME => $self->{TIME_STAMP}, EVENT => $history} ;

	$self->{TIME_STAMP}++ ;
	}
else
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't set attribute, variable '$options{NAME}' doesn't exist at '$location'!")  ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub GetAttribute
{

my ($self, @options) = @_ ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

if(defined wantarray)
	{
	unless(wantarray)
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: GetAttribute: called in scalar context at '$location'!\n") ;
		}
	}
else
	{
	$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetAttribute' called in void context at '$location'!\n") ;
	}
	
if(exists $options{CATEGORY})
	{
	if($self->{WARN_FOR_EXPLICIT_CATEGORY})
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: Setting '$options{NAME}' using explicit category at '$location'!\n") ;
		}
	}
else
	{
	$options{CATEGORY} = $self->{DEFAULT_CATEGORY} ;
	}

#~ use Data::TreeDumper ;
#~ print DumpTree {Options => \%options, Self => $self} ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$options{CATEGORY}' at at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Unexpected field VALUE at '$location'!") if exists $options{VALUE} ;

# inform of action if option set
if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: GetAttribute for '$options{CATEGORY}::$options{NAME}' at '$location'.\n") ;
	}

my @result ;

if(exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}})
	{
	my $config_variable = $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}} ;
	my $attribute_exist = exists $config_variable->{ATTRIBUTE};	
	
	if($attribute_exist)
		{
		@result = ($config_variable->{ATTRIBUTE}, $attribute_exist) ;
		}
	else
		{
		@result = (undef, $attribute_exist) ;
		}
	}
else
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Can't get attribute, variable '$options{NAME}' doesn't exist at '$location'!")  ;
	}

return(@result) ;
}

#-------------------------------------------------------------------------------

sub Validate
{

my ($self,$options, $set_status, $location, $config_variable_exists)  = @_ ;

my @validators ;

if($config_variable_exists)
	{
	my $config_variable = $self->{CATEGORIES}{$options->{CATEGORY}}{$options->{NAME}} ;

	# run variable validators
	for my $validator (keys %{$config_variable->{VALIDATORS}})
		{
		my$validator_origin = $config_variable->{VALIDATORS}{$validator}{ORIGIN} ;
		my $validator_sub = $config_variable->{VALIDATORS}{$validator}{SUB} ;
		
		if($self->{VERBOSE})
			{
			$self->{INTERACTION}{INFO}->("$self->{NAME}: running validator '$validator' defined at '$validator_origin' on '$options->{CATEGORY}::$options->{NAME}'.\n") ;
			}
			
		unless($validator_sub->($options->{VALUE}))
			{
			$self->{INTERACTION}{DIE}->
				("$self->{NAME}: Invalid value '$options->{VALUE}' for variable '$options->{NAME}'. Validator '$validator' defined at '$validator_origin'.\n") ;
			}
		}
	}
	
if(exists $options->{VALIDATORS})
	{
	# run local validator
	for my $validator (keys %{$options->{VALIDATORS}})
		{
		if($self->{VERBOSE})
			{
			$self->{INTERACTION}{INFO}->("$self->{NAME}: running local validator '$validator' defined at '$location'.\n") ;
			}
			
		unless($options->{VALIDATORS}{$validator}->($options->{VALUE}))
			{
			$self->{INTERACTION}{DIE}->
				("$self->{NAME}: Invalid value '$options->{VALUE}' for variable '$options->{NAME}'. Local validator '$validator' defined at '$location'.\n") ;
			}
		}
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub Get
{ ## no critic (ProhibitExcessComplexity)

my ($self, @options) = @_ ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	if($self->{WARN_FOR_EXPLICIT_CATEGORY})
		{
		my $plural = 'y' ;
		$plural = 'ies' if (@{$options{CATEGORIES_TO_EXTRACT_FROM}} > 1) ;
		
		$self->{INTERACTION}{WARN}->("$self->{NAME}: Getting '$options{NAME}' using explicit categor$plural at '$location'!\n") ;
		}
	}

#~ use Data::TreeDumper ;
#~ print DumpTree {Options => \%options, Self => $self} ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at $location!") unless defined $options{NAME} ;

# inform of action if option set
if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Getting '$options{NAME}' at '$location'.\n") ;
	}

unless(defined wantarray)
	{
	$self->{INTERACTION}{WARN}->("$self->{NAME}: Getting '$options{NAME}' in void context at '$location'!\n") ;
	}

# run debug hook if any
if(defined $self->{INTERACTION}{DEBUG})
	{
	my $category = exists $options{CATEGORY} ? "$options{CATEGORY}::" : $EMPTY_STRING ;
	
	$self->{INTERACTION}{DEBUG}->
		(
		"Getting '$category$options{NAME}' at '$location'.",
		$self,
		\%options,
		) ;
	}
	
my @categories_to_extract_from ;
my %categories_to_extract_from ;
my $user_defined_categories_to_extract_from = 0 ;

if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	$self->CheckCategoriesOrder(\%options, $location) ;
	
	@categories_to_extract_from = @{$options{CATEGORIES_TO_EXTRACT_FROM}} ;
	
	$user_defined_categories_to_extract_from++ ;
	%categories_to_extract_from = map {$_, 1} @categories_to_extract_from ;
	}
else
	{
	@categories_to_extract_from = @{$self->{CATEGORY_NAMES}} ;
	}


my ($value_found, $value, $found_in_category) = (0, undef, undef) ;

for my $category (@categories_to_extract_from)
	{
	my ($name_exists_in_category, $value_exists_in_category, $value_in_category, $name_in_category_is_overriden) 
		= $self->CheckVariableInCategory($category, $options{NAME}) ;
	
	next unless ($name_exists_in_category) ;
	
	# remember the value in case the overriding category is not in the list of categories to 
	# extract from
	$value_found++ ;
	
	$value             = $value_in_category ;
	$found_in_category = $category ;
	
	# check if lower priority category did an override
	if($name_in_category_is_overriden)
		{
		if(! $user_defined_categories_to_extract_from)
			{
			# get value from overriding category
			}
		else
			{
			# if this category was overridden by a category passed by the user
			# in CATEGORIES_TO_EXTRACT_FROM, use the overridden variable
			# otherwise, we are done
			
			my $current_categories_contain_overriding_category = 0 ;
			
			for my $override (@{ $name_in_category_is_overriden})
				{
				if(exists $categories_to_extract_from{$override->{CATEGORY}})
					{
					$current_categories_contain_overriding_category++ ;
					last ;
					}
				}
				
			if(! $current_categories_contain_overriding_category)
				{
				# we're done, return value from this category
				
				if($self->{VERBOSE})
					{
					$self->{INTERACTION}{INFO}->("\tfound in category '$found_in_category'.\n") ;
					}
				last ;
				}
			}
		}
	else
		{
		# we're done, return value from this category
		
		if($self->{VERBOSE})
			{
			$self->{INTERACTION}{INFO}->("\tfound in category '$found_in_category'.\n") ;
			}
		last ;
		}
	}


if($self->{LOG_ACCESS})	
	{
	push @{$self->{ACCESS_TO_VARIABLE}}, {%options} ;
	}

if(! $value_found)
	{
	if(! ($options{SILENT_NOT_EXISTS} ||  $self->{DISABLE_SILENT_OPTIONS}))
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: Variable '$options{NAME}' doesn't exist in categories [@categories_to_extract_from]at '$location'. Returning undef!\n") ;
		}
	}

if($options{GET_CATEGORY})
	{
	return($value, $found_in_category) ;
	}
else
	{
	return($value) ;
	}
}

#-------------------------------------------------------------------------------

sub CheckCategoriesOrder
{
	

my ($self, $options, $location) = @_ ;

my @default_categories = @{ $self->{CATEGORY_NAMES} } ;

for my $category ( @{ $options->{CATEGORIES_TO_EXTRACT_FROM} })
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category' at at '$location'!") unless exists $self->{VALID_CATEGORIES}{$category} ;

	shift @default_categories while(@default_categories && ($category ne $default_categories[0])) ;
	
	if(@default_categories)
		{
		shift @default_categories ;
		}
	else
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: categories in 'CATEGORIES_TO_EXTRACT_FROM' in an unexpected order at '$location'.\n") ;
		last ;
		}
	}
	
return ;
}

#-------------------------------------------------------------------------------

sub SetMultiple
{
	

my ($self, $options, @sets) = @_ ;

my ($package, $file_name, $line) = caller() ;

if('HASH' eq ref $options)
	{
	unless(defined $options->{FILE})
		{
		$options->{FILE} = $file_name ;
		$options->{LINE} = $line ;
		}
		
	}
else
	{
	unshift @sets, $options if defined $options ; 
	
	$options = {FILE => $file_name, LINE => $line} ;
	}
	
my $location = "$options->{FILE}:$options->{LINE}" ;

for my $set (@sets)
	{
	unless( 'ARRAY' eq ref $set)
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: 'SetMultiple' must be passed array reference at '$location'!\n") ;
		}
	
	$self->Set(%{$options}, @{$set}) ;
	}

return(1) ;
}

#-------------------------------------------------------------------------------

sub GetMultiple
{

my ($self, $options, @names) = @_ ;

my ($package, $file_name, $line) = caller() ;

if('HASH' eq ref $options)
	{
	unless(defined $options->{FILE})
		{
		$options->{FILE} = $file_name ;
		$options->{LINE} = $line ;
		}
		
	}
else
	{
	unshift @names, $options if defined $options ; 
	
	$options = {FILE => $file_name, LINE => $line} ;
	}
	
my $location = "$options->{FILE}:$options->{LINE}" ;

if(defined wantarray)
	{
	unless(wantarray)
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetMultiple' is not called in scalar context at '$location'!\n") ;
		}
	}
else
	{
	$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetMultiple' called in void context at '$location'!\n") ;
	}

my @values ;
for my $name (@names)
	{
	unless( $EMPTY_STRING eq ref $name)
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: 'GetMultiple' must be passed scalars at '$location'!\n") ;
		}
	
	push @values, scalar($self->Get(%{$options}, NAME => $name, GET_CATEGORY => 0)) ;
	}
	
return(@values) ;
}

#-------------------------------------------------------------------------------

sub GetKeys
{
	

my ($self, @options) = @_ ;

my ($package, $file_name, $line) = caller() ;
my $location = "$file_name:$line" ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: 'GetKeys' at '$location'\n") ;
	}

unless(defined wantarray)
	{
	$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetKeys' called in void context at '$file_name:$line'!\n") ;
	}
	
my (%variables, @categories_to_extract_from) ;

if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	@categories_to_extract_from = @{$options{CATEGORIES_TO_EXTRACT_FROM}} ;
	}
else
	{
	@categories_to_extract_from = @{$self->{CATEGORY_NAMES}} ;
	}
	
my %hash = map
			{
			$_ => 1
			} map
				{
				keys %{$self->{CATEGORIES}{$_}} ;
				}  @categories_to_extract_from ;

return(keys %hash) ;
}

#-------------------------------------------------------------------------------

sub GetKeyValueTuples
{

my ($self, @options) = @_ ;

my ($package, $file_name, $line) = caller() ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: 'GetKeyValueTuples' at '$file_name:$line'\n") ;
	}

unless(defined wantarray)
	{
	$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetKeyValueTuples' in void context at '$file_name:$line'!\n") ;
	}

# run debug hook if any
if(defined $self->{INTERACTION}{DEBUG})
	{
	$self->{INTERACTION}{DEBUG}->("'GetKeyValueTuples' at '$file_name:$line'.", $self, \@options,) ;
	}

my @list ;
my %hash = %{$self->GetHashRef(@options)} ;
 
while(my($n, $v) = each %hash)
	{
	push @list, {NAME => $n, VALUE => $v} ;
	}
	
return(@list) ;
}

#-------------------------------------------------------------------------------

sub GetHashRef
{

my ($self, @options) = @_ ;

my ($package, $file_name, $line) = caller() ;
my $location = "$file_name:$line" ;

$self->CheckOptionNames($VALID_OPTIONS, @options) ;

my %options = @options ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: 'GetHashRef' at '$location'\n") ;
	}

if(defined wantarray)
	{
	if(wantarray)
		{
		$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetHashRef' is called in array context at '$file_name:$line'!\n") ;
		}
	}
else
	{
	$self->{INTERACTION}{WARN}->("$self->{NAME}: 'GetHashRef' called in void context at '$file_name:$line'!\n") ;
	}
	
my (%variables, @categories_to_extract_from) ;

if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	@categories_to_extract_from = @{$options{CATEGORIES_TO_EXTRACT_FROM}} ;
	}
else
	{
	@categories_to_extract_from = @{$self->{CATEGORY_NAMES}} ;
	}
	
return 
	{
	map
		{
		$_ => scalar($self->Get(NAME => $_, CATEGORIES_TO_EXTRACT_FROM => [@categories_to_extract_from], FILE => $file_name, LINE => $line))
		} map
			{
			keys %{$self->{CATEGORIES}{$_}} ;
			}  @categories_to_extract_from
	} ;
}


#-------------------------------------------------------------------------------

sub SetDisplayExplicitCategoryWarningOption
{

my ($self, $value) = @_ ;

$self->{WARN_FOR_EXPLICIT_CATEGORY} = $value ;

if($self->{VERBOSE})
	{
	my ($package, $file_name, $line) = caller() ;
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Setting 'WARN_FOR_EXPLICIT_CATEGORY' to '$value' at '$file_name:$line'.\n") ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub SetDisableSilentOptions
{

my ($self, $silent) = @_ ;

$self->{DISABLE_SILENT_OPTIONS} = $silent ;

if($self->{VERBOSE})
	{
	my ($package, $file_name, $line) = caller() ;
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Setting 'DISABLE_SILENT_OPTIONS' to '$silent' at '$file_name:$line'.\n") ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------
	
sub LockCategories
{

my ($self, @categories) = @_ ;

my ($package, $file_name, $line) = caller() ;
my $location = "$file_name:$line" ;

for my $category (@categories)
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category' at '$location'!") unless exists $self->{VALID_CATEGORIES}{$category} ;
	$self->{LOCKED_CATEGORIES}{$category} = 1 ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------
	
sub Lock
{

my ($self, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

$options{CATEGORY} = $self->{DEFAULT_CATEGORY} unless exists $options{CATEGORY} ;

$self->CheckOptionNames($VALID_OPTIONS, %options) ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Locking '$options{CATEGORY}::$options{NAME}' at '$location'.\n") ;
	}

if(exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}})
	{
	my $config_variable = $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}} ;
	
	$config_variable->{LOCKED} = $location ;
	
	my $history = "LOCK. category = '$options{CATEGORY}' at '$options{FILE}:$options{LINE}', status = Lock: OK." ;
	push @{$config_variable->{HISTORY}}, {TIME => $self->{TIME_STAMP}, EVENT => $history} ;

	$self->{TIME_STAMP}++ ;
	}
else
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Locking unexisting '$options{CATEGORY}::$options{NAME}' at '$location'.\n") ;
	}

return(1) ;
}

#-------------------------------------------------------------------------------
	
sub UnlockCategories
{

my ($self, @categories) = @_ ;

for my $category (@categories)
	{
	delete $self->{LOCKED_CATEGORIES}{$category} ;
	}
	
return(1) ;
}

#-------------------------------------------------------------------------------

sub Unlock
{

my ($self, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

$options{CATEGORY} = $self->{DEFAULT_CATEGORY} unless exists $options{CATEGORY} ;

$self->CheckOptionNames($VALID_OPTIONS, %options) ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Unlocking '$options{CATEGORY}::$options{NAME}' at '$location'.\n") ;
	}
	
if(exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}})
	{
	my $config_variable = $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}} ;
	
	delete $config_variable->{LOCKED} ;
	
	my $history = "UNLOCK. category = '$options{CATEGORY}' at '$options{FILE}:$options{LINE}', status = Unlock: OK." ;
	push @{$config_variable->{HISTORY}}, {TIME => $self->{TIME_STAMP}, EVENT => $history} ;
	
	$self->{TIME_STAMP}++ ;
	}

return(1) ;
}
  
#-------------------------------------------------------------------------------

sub IsCategoryLocked
{

my ($self, $category) = @_ ;

my ($package, $file_name, $line) = caller() ;
my $location = "$file_name:$line" ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: No category at '$location'!") unless defined $category ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category' at '$location'!") unless exists $self->{VALID_CATEGORIES}{$category} ;

if(exists $self->{LOCKED_CATEGORIES}{$category})
	{
	return(1) ;
	}
else
	{
	return(0) ;
	}

}

#-------------------------------------------------------------------------------

sub IsLocked
{

my ($self, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

$options{CATEGORY} = $self->{DEFAULT_CATEGORY} unless exists $options{CATEGORY} ;

$self->CheckOptionNames($VALID_OPTIONS, %options) ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$options{CATEGORY}' at '$location'!") unless exists $self->{VALID_CATEGORIES}{$options{CATEGORY}} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Checking Lock of '$options{CATEGORY}::$options{NAME}' at '$location'.\n") ;
	}
	
my $locked = undef ;

if(exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}})
	{
	if(exists $self->{CATEGORIES}{$options{CATEGORY}}{$options{NAME}}{LOCKED})
		{
		$locked = 1 ;
		}
	else
		{
		$locked = 0 ;
		}
	}

return($locked) ;
}
  
#-------------------------------------------------------------------------------

sub Exists
{

my ($self, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

$self->CheckOptionNames($VALID_OPTIONS, %options) ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: 'CATEGORY' not used at '$location'!") if exists $options{CATEGORY} ;

if($self->{VERBOSE})
	{
	$self->{INTERACTION}{INFO}->("$self->{NAME}: Checking Existance of '$options{NAME}' at '$location'.\n") ;
	}
	
my @categories_to_extract_from ;

if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	if(defined $options{CATEGORIES_TO_EXTRACT_FROM})
		{
		@categories_to_extract_from = @{$options{CATEGORIES_TO_EXTRACT_FROM}} ;
		}
	else
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: undefined category 'CATEGORIES_TO_EXTRACT_FROM' at '$location'!") ;
		}
	}
else
	{
	@categories_to_extract_from = @{$self->{CATEGORY_NAMES}} ;
	}
	
my ($exists) = (0) ;

for my $category (@categories_to_extract_from)
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category' at '$location'!") unless exists $self->{VALID_CATEGORIES}{$category} ;
		
	if(exists $self->{CATEGORIES}{$category}{$options{NAME}})
		{
		$exists++ ;
		}
	}

return($exists) ;
}
  
#-------------------------------------------------------------------------------
  
sub GetHistory
{

my ($self, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

$self->CheckOptionNames($VALID_OPTIONS, %options) ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;
$self->{INTERACTION}{DIE}->("$self->{NAME}: bad argument 'CATEGORY' did you mean 'CATEGORIES_TO_EXTRACT_FROM'? at '$location'!") if exists $options{CATEGORY} ;

my @history ;
my @categories_to_extract_from ;

if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	if(defined $options{CATEGORIES_TO_EXTRACT_FROM})
		{
		@categories_to_extract_from = @{$options{CATEGORIES_TO_EXTRACT_FROM}} ;
		}
	else
		{
		$self->{INTERACTION}{DIE}->("$self->{NAME}: undefined category 'CATEGORIES_TO_EXTRACT_FROM' at '$location'!") ;
		}
	}
else
	{
	@categories_to_extract_from = @{$self->{CATEGORY_NAMES}} ;
	}
	
for my $category (@categories_to_extract_from)
	{
	$self->{INTERACTION}{DIE}->("$self->{NAME}: Invalid category '$category' at '$location'!") unless exists $self->{VALID_CATEGORIES}{$category} ;
		
	push @history, $self->GetVariableHistory($category, $options{NAME})  ;
	}
	
@history = sort {$a->{TIME} <=> $b->{TIME}} @history ;

return(\@history) ;
}

#-------------------------------------------------------------------------------

sub GetVariableHistory
{
	

my ($self, $category, $name) = @_ ;

if(exists $self->{ALIASED_CATEGORIES}{$category})
	{
	my $aliased = tied(%{ $self->{CATEGORIES}{$category} }) ;
	my $aliased_history = $aliased->{CONFIG}->GetHistory(NAME => $name) ;
	
	if(@{$aliased_history})
		{
		return 
			{
			"HISTORY FROM '$category' ALIASED TO '$aliased->{CONFIG}{NAME}'" => $aliased_history,
			TIME => $self->{ALIASED_CATEGORIES}{$category}{TIME_STAMP},
			} ;
		}
	else
		{
		return ;
		}
	}
else
	{
	if(exists $self->{CATEGORIES}{$category}{$name})
		{
		return(@{$self->{CATEGORIES}{$category}{$name}{HISTORY}}) ;
		}
	else
		{
		return  ;
		}
	}
}

#-------------------------------------------------------------------------------

sub GetHistoryDump
{

my ($self, @options) = @_ ;

if (@options % 2)
	{
	$self->{INTERACTION}{DIE}->('Invalid number of argument!') ;
	}

my %options = @options ;

$self->CheckOptionNames($VALID_OPTIONS, %options) ;

unless(defined $options{FILE})
	{
	my ($package, $file_name, $line) = caller() ;
	
	$options{FILE} = $file_name ;
	$options{LINE} = $line ;
	}

my $location = "$options{FILE}:$options{LINE}" ;

$self->{INTERACTION}{DIE}->("$self->{NAME}: Missing name at '$location'!") unless defined $options{NAME} ;

my ($config_name, $config_location) = $self->GetInformation() ;
my $config_information = "from config '$config_name' created at '$config_location'" ;

my @categories_to_extract_from ;
if(exists $options{CATEGORIES_TO_EXTRACT_FROM})
	{
	@categories_to_extract_from = (CATEGORIES_TO_EXTRACT_FROM => $options{CATEGORIES_TO_EXTRACT_FROM}) ;
	}
	
my @data_treedumper_options ;
if(exists $options{DATA_TREEDUMPER_OPTIONS})
	{
	@data_treedumper_options = @{ $options{DATA_TREEDUMPER_OPTIONS} } ;
	}

return
	(
	DumpTree
		(
		$self->GetHistory(NAME => $options{NAME}, @categories_to_extract_from),
		"History for variable '$options{NAME}' $config_information:",
		DISPLAY_ADDRESS => 0,
		@data_treedumper_options
		) 
	) ;
}

#-------------------------------------------------------------------------------

sub GetAccessLog
{

my ($self) = @_ ;

if(exists $self->{ACCESS_TO_VARIABLE})	
	{
	return($self->{ACCESS_TO_VARIABLE}) ;
	}
else
	{
	return [] ;
	}
}

#-------------------------------------------------------------------------------

sub GetDump
{

my ($self, @data_treedumper_options) = @_ ;

my ($package, $file_name, $line) = caller() ;

use Data::TreeDumper ;

my $sort_categories =
	sub
		{
		# DTD dumps hash with sorted keys
		# we display the categories in hierarchical order
		
	        my ($s, $level, $path, $keys) = @_ ;
		
		if($level == 1 && $path eq q<{'CATEGORIES'}>)
			{
			return('HASH', undef, @{$self->{CATEGORY_NAMES}}) ;
			}
		else
			{
			return(Data::TreeDumper::DefaultNodesToDisplay($s)) ;
			}
		} ;
		
return(DumpTree($self, $self->{NAME}, FILTER => $sort_categories, @data_treedumper_options)) ;
}
  
#-------------------------------------------------------------------------------

1 ;