view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

subtest '_load_driver() - returns false for nonexistent module' => sub {
	my $cfg = _make_cfg();
	my $result = $cfg->_load_driver('No::Such::Module::XYZ');
	ok(!$result, '_load_driver returns false for missing module');
};

subtest '_load_driver() - caches failed load' => sub {
	my $cfg = _make_cfg();
	$cfg->_load_driver('No::Such::Module::XYZ');
	ok($cfg->{failed}{'No::Such::Module::XYZ'}, 'failed load cached in {failed}');
};

subtest '_load_driver() - skips reload of already-loaded module' => sub {
	my $cfg = _make_cfg();
	$cfg->{loaded}{'Scalar::Util'} = 1;
	my $result = $cfg->_load_driver('Scalar::Util');
	is($result, 1, 'returns 1 from cache without re-requiring');
};

subtest '_load_driver() - skips retry of already-failed module' => sub {
	my $cfg = _make_cfg();
	$cfg->{failed}{'No::Such::Module::XYZ'} = 1;
	my $result = $cfg->_load_driver('No::Such::Module::XYZ');
	ok(!$result, 'returns false from cache without re-attempting');
};

# ===========================================================================
# Environment variable merging (via _load_config internals)
# ===========================================================================
subtest 'ENV vars with prefix override data values' => sub {
	local %ENV = %ENV;
	$ENV{'TESTAPP_RETRIES'} = '99';

	my $cfg = Config::Abstraction->new(
		data        => { TESTAPP => { retries => $EXPECTED_RETRIES } },
		config_dirs => [],
		env_prefix  => $ENV_PREFIX,
	);
	is($cfg->get('TESTAPP.retries'), '99', 'ENV var stored under prefix namespace');
};

subtest 'ENV vars with double-underscore create nested keys' => sub {
	local %ENV = %ENV;
	$ENV{'TESTAPP_DATABASE__USER'} = 'env_user';

	my $cfg = Config::Abstraction->new(
		data => {
			database => { user => $EXPECTED_USER, pass => $EXPECTED_PASS },
			retries  => $EXPECTED_RETRIES,
		},
		config_dirs => [],
		env_prefix  => $ENV_PREFIX,
	);
	is($cfg->get('database.user'), 'env_user', 'double-underscore ENV creates nested key');
};

# ===========================================================================
# Command-line argument merging (via _load_config internals)
# ===========================================================================
subtest 'CLI args override data values' => sub {
	local @ARGV = ("--TESTAPP_RETRIES=77");

	my $cfg = Config::Abstraction->new(
		data        => { retries => $EXPECTED_RETRIES },
		config_dirs => [],
		env_prefix  => $ENV_PREFIX,
	);
	is($cfg->get('retries'), '77', 'CLI arg overrides data value');
};

subtest 'CLI args with double-underscore create nested keys' => sub {
	# \%NESTED_DATA must not be used here - the CLI merge path modifies nested
	# hashrefs in-place via shared references from the shallow copy of 'data',
	# which would attempt to modify the Readonly nested hashrefs and die.
	# Use a fresh anonymous hash instead so the merge can write freely.
	local @ARGV = ('--TESTAPP_DATABASE__USER=cli_user');

	my $cfg = Config::Abstraction->new(
		data => {
			database => { user => $EXPECTED_USER, pass => $EXPECTED_PASS },
			retries  => $EXPECTED_RETRIES,
		},
		config_dirs => [],
		env_prefix  => $ENV_PREFIX,
	);
	is($cfg->get('database.user'), 'cli_user', 'CLI double-underscore creates nested key');
};

# ===========================================================================
# Coderef / blessed-object protection (regression for corruption bug)
# ===========================================================================
subtest 'coderef in data not corrupted by _load_config' => sub {
	my $cb = sub { $EXPECTED_CB_RESULT };
	my $cfg = Config::Abstraction->new(
		data        => { callback => $cb, tags => 'alpha,beta' },
		config_dirs => [],
	);
	my $got = $cfg->get('callback');
	is(reftype($got), 'CODE',         'coderef type intact after load');
	is($got->(), $EXPECTED_CB_RESULT, 'coderef callable after load');
};

subtest 'blessed object in data not corrupted by _load_config' => sub {
	my $obj = bless { v => $EXPECTED_PORT }, '_BlessedVal';
	my $cfg = Config::Abstraction->new(
		data        => { handler => $obj },
		config_dirs => [],
	);
	my $got = $cfg->get('handler');
	ok(blessed($got),                'blessed object intact after load');
	is(blessed($got), '_BlessedVal', 'class name unchanged after load');
};

# ===========================================================================
# TestProxy -- minimal subclass that satisfies the UNIVERSAL::isa guard on
# _load_remote_dir and _parse_config_string.  Calling those methods directly
# from 'main' would croak; routing through a genuine subclass keeps the guard
# happy without altering the behaviour under test.
# ===========================================================================
package Config::Abstraction::TestProxy;
use parent -norequire, 'Config::Abstraction';
sub test_load_remote_dir     { my $self = shift; return $self->_load_remote_dir(@_)     }
sub test_parse_config_string { my $self = shift; return $self->_parse_config_string(@_) }
package main;

# Provide a minimal stub so remote-path tests run whether or not
# File::Slurp::Remote is installed.  Individual subtests mock the body.
unless(eval { require File::Slurp::Remote; 1 }) {
	no warnings 'once';
	*File::Slurp::Remote::read_file = sub {};
	$INC{'File/Slurp/Remote.pm'} = 1;
}

Readonly::Scalar my $REMOTE_HOST  => 'cfg.example.com';
Readonly::Scalar my $REMOTE_DIR   => '/etc/myapp';
Readonly::Scalar my $REMOTE_USER  => 'deploy';

t/function.t  view on Meta::CPAN

	ok(exists $es->{'retries'},    'top-level key has audit record');
	is(ref($es->{'retries'}{sources}), 'ARRAY', 'sources field is an arrayref');
};

subtest 'explain_sources() - data source recorded with correct type and label' => sub {
	my $cfg = _make_cfg();
	my $es  = $cfg->explain_sources();

	my @data_srcs = grep { $_->{type} eq 'data' } @{$es->{'retries'}{sources}};
	ok(scalar(@data_srcs) > 0,       'at least one data-layer source found');
	is($data_srcs[0]{label}, 'constructor data argument',
		'data source label is "constructor data argument"');
	is($data_srcs[0]{value}, $EXPECTED_RETRIES, 'data source value correct');
};

subtest 'explain_sources() - final value matches get() for same key' => sub {
	my $cfg = _make_cfg();
	my $es  = $cfg->explain_sources();
	is($es->{'retries'}{value}, $cfg->get('retries'),
		'explain_sources final value equals get() result');
};

subtest 'explain_sources() - env source recorded with env var name as label' => sub {
	local %ENV = %ENV;
	delete $ENV{APP_DATABASE__HOST};
	$ENV{APP_DATABASE__HOST} = 'env_host_value';

	my $cfg = Config::Abstraction->new(
		data        => { database => { host => 'default' } },
		config_dirs => [],
		env_prefix  => 'APP_',
	);
	my $es = $cfg->explain_sources();

	my @env_srcs = grep { $_->{type} eq 'env' } @{$es->{'database.host'}{sources}};
	ok(scalar(@env_srcs) > 0,                  'env source recorded');
	is($env_srcs[0]{label}, 'APP_DATABASE__HOST', 'env label is the env var name');
	is($env_srcs[0]{value}, 'env_host_value',     'env source value correct');
	diag("env source: " . $env_srcs[0]{label}) if $ENV{TEST_VERBOSE};
};

# ===========================================================================
# _value_from_type() -- source record lookup internals
# ===========================================================================
subtest '_value_from_type() - (0, undef) for undef key' => sub {
	my $cfg = _make_cfg();
	my ($found, $val) = $cfg->_value_from_type('data', undef);
	is($found, 0,      'found=0 for undef key');
	ok(!defined($val), 'val=undef for undef key');
};

subtest '_value_from_type() - (1, value) for data-sourced key' => sub {
	my $cfg = _make_cfg();
	my ($found, $val) = $cfg->_value_from_type('data', 'retries');
	is($found, 1,                 'found=1');
	is($val,   $EXPECTED_RETRIES, 'correct value');
};

subtest '_value_from_type() - (0, undef) when type did not contribute' => sub {
	# No CLI args in @ARGV, so argv layer should not have contributed
	local @ARGV = ();
	my $cfg = _make_cfg();
	my ($found, $val) = $cfg->_value_from_type('argv', 'retries');
	ok(!$found,        'found is false when argv did not set the key');
	ok(!defined($val), 'val=undef when argv did not contribute');
};

subtest '_value_from_type() - normalises sep_char to dot before lookup' => sub {
	# Source records always use '.' regardless of sep_char.
	# _value_from_type must translate sep_char-separated keys before searching.
	my $cfg = Config::Abstraction->new(
		data        => { database => { user => $EXPECTED_USER } },
		config_dirs => [],
		sep_char    => '/',
	);
	my ($found, $val) = $cfg->_value_from_type('data', 'database/user');
	is($found, 1,                'sep_char normalised to dot for record lookup');
	is($val,   $EXPECTED_USER,   'correct value after normalisation');
};

# ===========================================================================
# prefer_env() / prefer_file() / prefer_data() / prefer_argv()
# ===========================================================================
subtest 'prefer_data() - returns data-layer value even when file overrides it' => sub {
	plan skip_all => 'requires filesystem' if $^O eq 'MSWin32';
	require File::Temp;
	my $dir = File::Temp::tempdir(CLEANUP => 1);
	open my $fh, '>', "$dir/base.yaml" or die "Cannot write: $!";
	print $fh "retries: 99\n";
	close $fh;

	my $cfg = Config::Abstraction->new(
		data        => { retries => $EXPECTED_RETRIES },
		config_dirs => [$dir],
	);
	# file sets retries=99; prefer_data must bypass the file and return the data value
	is($cfg->prefer_data('retries'), $EXPECTED_RETRIES,
		'prefer_data returns data value (3) despite file override (99)');
	is($cfg->get('retries'), 99, 'get() confirms file override wins in merged config');
};

subtest 'prefer_data() - falls back to get() when data layer did not set the key' => sub {
	plan skip_all => 'requires filesystem' if $^O eq 'MSWin32';
	require File::Temp;
	my $dir = File::Temp::tempdir(CLEANUP => 1);
	open my $fh, '>', "$dir/base.yaml" or die;
	print $fh "only_in_file: yes\n";
	close $fh;

	my $cfg = Config::Abstraction->new(
		data        => { something_else => 1 },
		config_dirs => [$dir],
	);
	is($cfg->prefer_data('only_in_file'), 'yes',
		'prefer_data falls back to get() for key not in data layer');
};

subtest 'prefer_env() - returns env value, not higher-priority argv override' => sub {
	local %ENV = %ENV;
	delete $ENV{APP_DATABASE__HOST};
	$ENV{APP_DATABASE__HOST} = 'env-host';
	local @ARGV = ('--APP_DATABASE__HOST=argv-host');

	my $cfg = Config::Abstraction->new(
		data        => { database => { host => 'default' } },
		config_dirs => [],
		env_prefix  => 'APP_',
	);
	is($cfg->prefer_env('database.host'), 'env-host',
		'prefer_env returns env value, bypassing argv');
	is($cfg->get('database.host'), 'argv-host',
		'get() confirms argv wins in merged config');
};

subtest 'prefer_env() - falls back to get() when no env contributed' => sub {
	local %ENV = %ENV;
	delete $ENV{APP_RETRIES};

	my $cfg = _make_cfg();
	is($cfg->prefer_env('retries'), $EXPECTED_RETRIES,
		'prefer_env falls back to get() when env did not contribute');
};

subtest 'prefer_argv() - returns argv value when CLI arg provided' => sub {
	local @ARGV = ('--APP_DATABASE__HOST=argv-host');
	local %ENV  = %ENV;
	delete $ENV{APP_DATABASE__HOST};

	my $cfg = Config::Abstraction->new(
		data        => { database => { host => 'default' } },
		config_dirs => [],
		env_prefix  => 'APP_',
	);
	is($cfg->prefer_argv('database.host'), 'argv-host',
		'prefer_argv returns argv-layer value');
};

subtest 'prefer_argv() - falls back to get() when no argv contributed' => sub {
	local @ARGV = ();
	my $cfg = _make_cfg();
	is($cfg->prefer_argv('retries'), $EXPECTED_RETRIES,
		'prefer_argv falls back to get() when @ARGV did not contribute');
};

subtest 'prefer_file() - returns file value when a file set the key' => sub {
	plan skip_all => 'requires filesystem' if $^O eq 'MSWin32';
	require File::Temp;
	my $dir = File::Temp::tempdir(CLEANUP => 1);
	open my $fh, '>', "$dir/base.yaml" or die;
	print $fh "retries: 99\n";
	close $fh;

	local %ENV = %ENV;
	delete $ENV{APP_RETRIES};

	my $cfg = Config::Abstraction->new(
		data        => { retries => $EXPECTED_RETRIES },
		config_dirs => [$dir],
	);
	is($cfg->prefer_file('retries'), 99,
		'prefer_file returns file-layer value (99)');
};

subtest 'prefer_file() - falls back to get() when no file set the key' => sub {
	# data-only config: no file layer contributed
	my $cfg = _make_cfg();
	is($cfg->prefer_file('retries'), $EXPECTED_RETRIES,
		'prefer_file falls back to get() when no file contributed');
};

# ===========================================================================
# _flatten_keys() -- nested hash flattening (package function, no $self)
# ===========================================================================
subtest '_flatten_keys() - three-level nesting produces dotted key' => sub {
	my %flat = Config::Abstraction::_flatten_keys({ a => { b => { c => 'leaf' } } });
	is($flat{'a.b.c'}, 'leaf', 'three-level nesting produces a.b.c');
	is(scalar(keys %flat), 1,  'exactly one key');
};

subtest '_flatten_keys() - top-level scalars passed through' => sub {
	my %flat = Config::Abstraction::_flatten_keys({ x => 1, y => 'str' });
	is($flat{x}, 1,     'integer preserved');
	is($flat{y}, 'str', 'string preserved');
};

subtest '_flatten_keys() - config_path key skipped at every level' => sub {
	my %flat = Config::Abstraction::_flatten_keys({
		normal      => 'v',
		config_path => ['/path'],
		nested      => { config_path => ['/n'] },
	});
	ok( exists $flat{normal},             'normal key present');
	ok(!exists $flat{config_path},        'top-level config_path skipped');
};

subtest '_flatten_keys() - empty hash gives empty flat hash' => sub {
	my %flat = Config::Abstraction::_flatten_keys({});
	is(scalar(keys %flat), 0, 'empty input -> empty output');
};