locked results from the CPAN

locked

Config-Hierarchical

view release on metacpan or search on metacpan

		default callback is a dumper
			default dumper can also get arguments

	return a diff data structure that can be displayed by any dumper

#package Config::Hierarchical::Tie::ReadOnly
	same as GetHashref but the values are kept in the config object, usufull to save memory when doing EvalString

# GENERATE WARNING for ALIASED categories

#can we override a locked variable => yes, no warnings (except override)

!Add sub to initalize a category in one call. once initialized, it shall not be possible to initialize
	a category again.
	=> use INITIAL_VALUES
	
#Add sub to extract a config for user defined categories. the returned config should be directly usable
	to initialize another category
	
	my $config_1 = new Config::Hierarchical(.....) ;

Todo.txt view on Meta::CPAN

	variable
#lock status is not added to history when locking is done through 'set'. 
	OK when	done through 'lock'
#typo in GetCategories example
#Do we keep a history of warnings (protected, ignored, ...) and should it be an option

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

#test utilities
#wantarray
#locked categories
#custom get
#custom Get Hash ref
#document  code
#=head1 TEST, COVERAGE and EXAMPLES
#test pod, syntax, critic ...
#coverage
#check the extra test modules in Xmas proj
#check all coverage tests and make them real tests
#Manifest, README, ...

lib/Config/Hierarchical.pm view on Meta::CPAN

=item INFO

This sub will be used when displaying B<verbose> information.

=item WARN

This sub will be used when a warning is displayed. e.g. a configuration that is refused or an override.

=item DIE

Used when an error occurs. E.g. a locked variable is set.

=item DEBUG

If this option is set, Config::Hierarchical will call the sub before and after acting on the configuration.
This can act as a breakpoint in a debugger or allows you to pinpoint a configuration problem.

=back

The functions default to:

lib/Config/Hierarchical.pm view on Meta::CPAN

	}

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}  ;

lib/Config/Hierarchical.pm view on Meta::CPAN

Configuration validators that will only be used during this call to B<Set>. The I<SET_VALIDATOR> set in the constructor
will not be called if this option is set. This lets you add configuration variable from different source and check them
with specialized validators.

=item * VALIDATORS

Extra validators that will only be used during this call to B<Set>.

=item * FORCE_LOCK

If a variable is locked, trying to set it will generate an error. It is possible to temporarily force
the lock with this option. A warning is displayed when a lock is forced.

=item * LOCK

Will lock the variable if set to 1, unlock if set to 0.

=item * OVERRIDE

This allows the variable in a category to override the variable in a category with higher priority. Once a variable
is overridden, it's value will always be the override value even if it is set again.

lib/Config/Hierarchical.pm view on Meta::CPAN

	$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} ;

lib/Config/Hierarchical.pm view on Meta::CPAN

		{
		$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} ;

lib/Config/Hierarchical.pm view on Meta::CPAN

return(1) ;
}

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

=head2 LockCategories(@categories)

Locks the categories passed as argument. A variable in a locked category can not be set.
An attempt to set a locked variable will generate an error. B<FORCE_LOCK> has no effect on locked categories.

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

I<Arguments>

=over 2 

=item * @categories - a list of categories to lock

=back

lib/Config/Hierarchical.pm view on Meta::CPAN

return(1) ;
}

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

=head2 Lock(NAME => $variable_name, CATEGORY => $category)

Locks a variable in the default category or an explicit category. A locked variable can not be set.

To set a locked variable, B<FORCE_LOCK> can be used. B<FORCE_LOCK> usually pinpoints a problem
in your configuration.

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

I<Arguments>

=over 2 

=item * NAME => $variable_name - Name of the variable to lock

lib/Config/Hierarchical.pm view on Meta::CPAN

$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
{

=head2 Exists(NAME => $variable_name, CATEGORIES_TO_EXTRACT_FROM =>  \@categories)

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

t/005_set_get_default.t view on Meta::CPAN

					{CATEGORY => 'CURRENT', NAME => 'LD', VALUE => 3, LOCK => 1},
					{NAME => 'AS', VALUE => 4, LOCK => 1},
					
					{NAME => 'STRUCTURE', VALUE => $structure},
					{NAME => 'OBJECT', VALUE => $object},
					] ,
				) ;
				
is(defined $config, 1, 'constructor with initial values') ;

is($config->IsLocked(NAME => 'CC'), 0, 'config not locked') ;
is($config->IsLocked(NAME => 'LD'), 1, 'config locked') ;

is($config->Get(NAME => 'CC'), '2', 'initialized ok') or diag  $config->GetDump();
is($config->Get(NAME => 'LD'), '3', 'initialized ok') ;
is($config->Get(CATEGORY => 'CURRENT', NAME => 'AS'), 4, 'initialized ok') ;

is($config->Exists(NAME => 'AS'), 1, 'exist') ;

is($config->Exists(NAME => 'AS', CATEGORIES_TO_EXTRACT_FROM => ['CURRENT']), 1, 'exist') ;
dies_ok
	{

t/005_set_get_default.t view on Meta::CPAN

		[NAME => 'LCC1', VALUE => 'gcc1'], 
		) ;

# die
dies_ok
	{
	$config->SetMultiple
		(
		[NAME => 'LCC', VALUE => 'gccx'], 
		) ;
	} "setting locked variable" ;
	
# die
dies_ok
	{
	$config->SetMultiple
			(
			{FORCE_LOCK => 1},
			[NAME => 'LCC', VALUE => 'gccx', FORCE_LOCK => 0], 
			) ;
	} "ignoring option" ;

t/005_set_get_default.t view on Meta::CPAN

warning_like
	{
	lives_ok
		{
		$config->SetMultiple
				(
				{FORCE_LOCK => 1 , FILE => __FILE__, LINE => __LINE__},
				[NAME => 'LCC', VALUE => 'gccx'], 
				) ;
		} "option working" ;
	} qr/Forcing locked/i, "forcing warning";
	
# dies, but first variable is set before die is called
warning_like
	{
	dies_ok
		{
		$config->SetMultiple
			(
			{FORCE_LOCK => 1, FILE => __FILE__, LINE => __LINE__},
			[NAME => 'LCC', VALUE => 'gccy'], 
			[NAME => 'LCC1', VALUE => 'gccz', FORCE_LOCK => 0], 
			) ;
		} "one variable uses options the other not" ;
	} qr/Forcing locked/i, "forcing warning";

is($config->Get(NAME => 'LCC') , 'gccy', 'one value forced lock') ;

}

{
local $Plan = {'multiple get and hash ref' => 8} ;

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

t/006_set_get_categories.t view on Meta::CPAN

					[
					{CATEGORY => 'CLI', NAME => 'CC', VALUE => 1},
					{CATEGORY => 'CLI', NAME => 'CC', VALUE => 2},
					{CATEGORY => 'CURRENT', NAME => 'LD', VALUE => 3, LOCK => 1},
					{NAME => 'AS', VALUE => 4, LOCK => 1},
					] ,
				) ;
				
is(defined $config, 1, 'constructor with initial values') ;

is($config->IsLocked(NAME => 'CC', CATEGORY => 'CLI'), 0, 'config not locked') ;
is($config->IsLocked(NAME => 'LD'), 1, 'config locked') ;

is($config->Get(NAME => 'CC'), '2', 'initialized ok') ;
is($config->Get(NAME => 'LD'), '3', 'initialized ok') ;
is($config->Get(CATEGORY => 'CURRENT', NAME => 'AS'), 4, 'initialized ok') ;

is($config->Exists(NAME => 'LD'), 1, 'exist') ;
is($config->Exists(NAME => 'CC'), 1, 'exist') ;
is($config->Exists(NAME => 'NOT_EXIST'), 0, 'not exist') ;

dies_ok

t/010_lock.t view on Meta::CPAN

use Test::Block qw($Plan);

use Config::Hierarchical ; 

{
local $Plan = {'locking' => 13} ;

my $config = new Config::Hierarchical() ;
$config->Set(NAME => 'CC', VALUE => 'gcc', LOCK => 1) ;

ok($config->IsLocked(NAME => 'CC'), 'config locked') ;

$config->Unlock(NAME => 'CC') ;
is($config->IsLocked(NAME => 'CC'), 0, 'config unlocked') ;

$config->Lock(NAME => 'CC') ;
ok($config->IsLocked(NAME => 'CC'), 'config locked') ;

throws_ok
	{
	$config->Set(NAME => 'WHATEVER', VALUE => 1, LOCK => 1) ;
	$config->Set(NAME => 'WHATEVER', VALUE => 2, LOCK => 0) ;
	} qr/was locked and couldn't be set/, "can't unlock without FORCE_LOCK" ;

warning_like
	{
	$config->Set(NAME => 'CC', VALUE => 'gcc2', FORCE_LOCK => 1, LOCK => 0) ;
	} qr/Forcing locked/i, "forcing warning";

is($config->Get(NAME => 'CC'), 'gcc2', 'forced lock') ;
is($config->IsLocked(NAME => 'CC'), 0, 'config unlocked') ;


$config->Lock(NAME => 'CC') ;
dies_ok
	{
	$config->Set(NAME => 'CC', VALUE => 'gccx') ;
	} "can't set locked variable" ;
	
dies_ok
	{
	$config->Lock(NAME => 'UNEXISTANT') ;
	} "can't locked unexisting variable" ;

dies_ok
	{
	$config->Lock(NAME => 'CC', CATEGORY => 'NOT_EXISTS') ;
	} "can't lock unexisting category" ;
	
dies_ok
	{
	$config->Unlock(NAME => 'CC', CATEGORY => 'NOT_EXISTS') ;
	} "can't unlock unexisting category" ;

t/010_lock.t view on Meta::CPAN


$config->Unlock(NAME => 'NOT_EXIST') ;
}

{
local $Plan = {'locking in category' => 5} ;

my $config = new Config::Hierarchical() ;
$config->Set(NAME => 'CC', VALUE => 'gcc', LOCK => 1) ;

ok($config->IsLocked(NAME => 'CC', CATEGORY => 'CURRENT'), 'config locked') ;

$config->Unlock(NAME => 'CC', CATEGORY => 'CURRENT') ;
is($config->IsLocked(NAME => 'CC'), 0, 'config unlocked') ;
is($config->IsLocked(NAME => 'NOT_EXIST'), undef, 'variable does not exist') ;

dies_ok
	{
	$config->IsLocked(CATEGORY => 'NOT_EXISTS', NAME => 'CC') ;
	} "Can't query unexisting category" ;

dies_ok
	{
	$config->IsLocked() ;

t/015_lock_categories.t view on Meta::CPAN

				] ,
			INTERACTION            =>
				{
				# work around error in Test::Warn
				WARN  => sub{my $message = join(' ', @_) ; $message =~ s[\n][]g ;  use Carp ;carp $message; },
				},
			LOCKED_CATEGORIES => ['A', 'C'],	
			) ;
			
	is($config->Get(NAME => 'CC'), 'B', 'override is sticky') ;
	is($config->Get(NAME => 'CC', CATEGORIES_TO_EXTRACT_FROM => ['A']), 'A', 'locked categories are initialized') ;
	}
	[
	#~ # check which warnings are generated
	qr/Setting 'B::CC'.*Overriding 'A::CC'/,
	qr/Variable 'A::CC' was overridden/,
	], "override warnings" ;
	
throws_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'A', VALUE => 1) ;
	} qr/category 'A' was locked/, "can't write a locked category" ;
	
throws_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'A', VALUE => 1, FORCE_LOCK => 1) ;
	} qr/category 'A' was locked/, "can't FORCE_LOCK a locked category" ;

throws_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'C', VALUE => 1) ;
	} qr/category 'C' was locked/, "can't write a locked category" ;
	
$config->UnlockCategories('C') ;	
lives_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'C', VALUE => 1) ;
	} "can write an unlocked category" ;

}

{
local $Plan = {'lock category' => 11} ;

my $config;

warnings_like
	{

t/015_lock_categories.t view on Meta::CPAN

	#~ # check which warnings are generated
	qr/Setting 'B::CC'.*Overriding 'A::CC'/,
	qr/Variable 'A::CC' was overridden/,
	], "override warnings" ;
	
$config->LockCategories('A') ;	

throws_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'A', VALUE => 1) ;
	} qr/category 'A' was locked/, "can't write a locked category" ;
	
throws_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'A', VALUE => 1, FORCE_LOCK => 1) ;
	} qr/category 'A' was locked/, "can't FORCE_LOCK a locked category" ;
	
	
$config->LockCategories('C') ;	

throws_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'C', VALUE => 1, FORCE_LOCK => 1) ;
	} qr/category 'C' was locked/, "can't write a locked category" ;
	
$config->UnlockCategories('C') ;	

lives_ok
	{
	$config->Set(NAME => 'WHATEVER', CATEGORY => 'C', VALUE => 1) ;
	} "can write an unlocked category" ;

throws_ok
	{
	$config->LockCategories('X') ;	
	} qr/Invalid category 'X'/, "can't lock unexisting category" ;

throws_ok
	{
	$config->IsCategoryLocked('X') ;	
	} qr/Invalid category 'X'/, "unexisting category" ;

throws_ok
	{
	$config->IsCategoryLocked() ;	
	} qr/No category/, "No category" ;

is($config->IsCategoryLocked('A'), 1, 'locked') ;
is($config->IsCategoryLocked('C'), 0, 'not locked') ;

}

t/099_Cookbook.t view on Meta::CPAN


=begin hidden

# the code above generates an error and dies so we can't run it directly in a common section

	dies_ok
		{
		$config->Set(NAME => 'CC', VALUE => 'gcc') ;
		$config->Lock(NAME => 'CC') ;
		$config->Set(NAME => 'CC', VALUE => 'cl') ;
		} 'Setting locked variable' ;
	
	$die =~ s/^/\t/gm ;
	generate_pod($die . "\n") ;
	
	$cc_value = $config->Get(NAME => 'CC') ;
	is($cc_value, 'gcc', 'Get returns right value') ;

=end hidden

=head4 Setting Locked variables

t/099_Cookbook.t view on Meta::CPAN


	$cc_value = $config->Get(NAME => 'CC') ;
	is($cc_value, 'cl', 'Get returns right value') ;
	generate_pod("\t$warnings\n") ;
	generate_pod("\tValue for 'CC' is '$cc_value'.\n\n") ;

=end hidden

=head4 Getting the lock state

	print "'CC' is locked.\n" if $config->IsLocked(NAME => 'CC') ;
	print "'LD' is locked.\n" if $config->IsLocked(NAME => 'LD') ;

Would display:

=begin hidden

	is($config->IsLocked(NAME => 'LD'), 0, 'config not locked') ;
	is($config->IsLocked(NAME => 'CC'), 1, 'config locked') ;
	
	generate_pod("\t'CC' is locked.\n") if $config->IsLocked(NAME => 'CC') ;
	generate_pod("\t'LD' is locked.\n") if $config->IsLocked(NAME => 'LD') ;
	generate_pod("\n") ;

=end hidden

=for POD::Tested reset

=head2 Setting variable  in the constructor

	use Config::Hierarchical ;

t/099_Cookbook.t view on Meta::CPAN

					{NAME => 'AS', VALUE => 4, LOCK => 1},
					],
				) ;

=begin hidden

	my ($warnings, $die) ;
	$config->{INTERACTION}{WARN} = sub{$warnings = join('', @_) ; use Carp ;carp $warnings; } ;
	$config->{INTERACTION}{DIE} = sub{$die= join('', @_) ; use Carp ;croak $die} ; 
	
	is($config->IsLocked(NAME => 'CC'), 0, 'config not locked') ;
	is($config->IsLocked(NAME => 'LD'), 1, 'config locked') ;
	
	is($config->Get(NAME => 'CC'), '2', 'initialized ok') or diag  $config->GetDump();
	is($config->Get(NAME => 'LD'), '3', 'initialized ok') ;
	is($config->Get(CATEGORY => 'CURRENT', NAME => 'AS'), 4, 'initialized ok') ;
	
	is($config->Exists(NAME => 'AS'), 1, 'exist') ;

=end hidden

=head2 Getting a non existing variable value

( run in 1.033 second using v1.01-cache-2.11-cpan-49f99fa48dc )