view release on metacpan or  search on metacpan

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

	}

	# config_checker_source() returns Perl source text (a sub { ... } literal)
	# that must be eval'd so it can import into our namespace.
	my $checker = eval Config::Checker::config_checker_source();	## no critic (ProhibitStringyEval)
	Carp::croak(ref($self) . ": failed to compile Config::Checker: $@") if $@;

	eval { $checker->($self->{'config'}, $prototype) };
	Carp::croak(ref($self) . ": checker validation failed: $@") if $@;
}

# Determine if a value is a plain, unblessed, non-reference scalar
# safe to use in regex/string operations.
# Args:   value to test
# Returns: 1 if plain scalar, 0 otherwise
sub _is_plain_scalar
{
	my $val = $_[0];

	return 0 if !defined($val);
	return 0 if Scalar::Util::blessed($val);
	return 0 if ref($val);
	return 1;
}

# Recursively flatten a nested hashref to dotted keys (always uses '.' as separator).
# Skips the meta-key 'config_path'. Used by explain_sources() and source tracking.
# $seen guards against circular references (e.g. those possible when
# Hash::Merge::set_clone_behavior(0) is active).
#
# _flatten_into writes into a caller-supplied hashref accumulator so that
# each leaf key is written exactly once -- O(N) total writes vs the previous
# O(N^2) pattern of %flat = (%flat, _flatten_keys(...)) at each recursion level.
sub _flatten_into
{
	my ($acc, $hash, $prefix, $seen) = @_;
	return unless ref($hash) eq 'HASH';
	my $addr = Scalar::Util::refaddr($hash);
	return if $seen->{$addr}++;
	for my $k (keys %$hash) {
		next if $k eq 'config_path';
		my $full = length($prefix) ? "$prefix.$k" : $k;
		if(ref($hash->{$k}) eq 'HASH') {
			_flatten_into($acc, $hash->{$k}, $full, $seen);
		} else {
			$acc->{$full} = $hash->{$k};
		}
	}
}

sub _flatten_keys
{
	my ($hash, $prefix, $seen) = @_;
	my %flat;
	_flatten_into(\%flat, $hash, $prefix // '', $seen // {});
	return %flat;
}

sub _load_config
{
	if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) {
		Carp::croak('Illegal Operation: This method can only be called by a subclass');
	}

	my $self = shift;

	# Disable Hash::Merge cloning for the duration of this method.
	# Storable::dclone (used when clone=1) cannot handle coderefs or blessed
	# objects that may appear in the 'data' argument; sharing references is
	# safe here because %merged is a fresh, method-local accumulator.
	my $saved_clone = Hash::Merge::get_clone_behavior();
	Hash::Merge::set_clone_behavior(0);

	my %merged;

	if($self->{'data'}) {
		# The data argument given to 'new' contains defaults that this routine will override
		if(ref($self->{'data'}) eq 'HASH') {
			%merged = %{$self->{'data'}};
			push @{$self->{'_source_records'}}, {
				type      => 'data',
				label     => 'constructor data argument',
				flat_data => { _flatten_keys($self->{'data'}) },
			};
		} else {
			Carp::carp(ref($self) . ': data argument must be a hashref; ignoring non-hashref value');
		}
	}

	my $logger = $self->{'logger'};
	if($logger) {
		$logger->trace(ref($self), ' ', __LINE__, ': Entered _load_config');
	}

	my $environment = $self->_get_environment();
	my @_formats    = qw(yaml yml json xml ini toml);
	my @_file_list  = (
		(map { "base.$_"              } @_formats),
		($environment ? (map { "base.$environment.$_"  } @_formats) : ()),
		(map { "local.$_"             } @_formats),
		($environment ? (map { "local.$environment.$_" } @_formats) : ()),
	);

	my @dirs = @{$self->{'config_dirs'}};
	if($self->{'config_file'} && (scalar(@dirs) > 1)) {
		if(File::Spec->file_name_is_absolute($self->{'config_file'})) {
			# Handle absolute paths
			@dirs = ('');
		} else {
			# Look in the current directory
			push @dirs, File::Spec->curdir();
		}
	}
	for my $dir (@dirs) {
		next if(!defined($dir));

		# Newcastle Connection: /../hostname/path means read from a remote host.
		# /../ is unreachable on any real filesystem, so this is unambiguous.
		# When the hostname resolves to the local machine (localhost, 127.0.0.1,
		# ::1, or the system hostname) the /../host/ wrapper is unwrapped and the
		# enclosed path is processed through the normal local pipeline instead.

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

# ---------------------------------------------------------------------------
# _parse_remote_dir -- detect Newcastle Connection style paths.
#
# Returns ($host, $dir) when $dir begins with /../, empty list otherwise.
# The /../ prefix is syntactically impossible for a real local path so no
# real directory entry is ever misidentified.
# ---------------------------------------------------------------------------
sub _parse_remote_dir
{
	my ($self, $dir) = @_;

	return unless defined($dir);
	return unless $dir =~ m{^\Q/../\E([^/]+)(/.+)?$};
	return ($1, $2 // '/');
}

# ---------------------------------------------------------------------------
# _is_local_host -- true when $host refers to the machine running this code.
#
# Strips any user@ prefix first, then checks the four common ways a caller
# might spell "here": the loopback name, the two loopback addresses, and the
# system hostname (both fully-qualified and short).  Comparison is
# case-insensitive because hostnames are case-insensitive by RFC 1034.
# ---------------------------------------------------------------------------
sub _is_local_host
{
	my ($self, $host) = @_;

	return 0 unless defined($host) && length($host);

	(my $bare = $host) =~ s/^[^@]+@//;	# strip optional user@ prefix

	return 1 if lc($bare) eq 'localhost';
	return 1 if $bare eq '127.0.0.1';
	return 1 if $bare eq '::1';

	# Cache the resolved hostname on the object so Sys::Hostname::hostname()
	# (a syscall) is only made once per Config::Abstraction instance.
	unless(defined $self->{'_cached_hostname'}) {
		require Sys::Hostname;
		$self->{'_cached_hostname'} = lc(Sys::Hostname::hostname());
		($self->{'_cached_short_hostname'} = $self->{'_cached_hostname'}) =~ s/\..*$//;
	}
	return 1 if lc($bare) eq $self->{'_cached_hostname'};
	return 1 if lc($bare) eq $self->{'_cached_short_hostname'};

	return 0;
}

# ---------------------------------------------------------------------------
# _load_remote_dir -- fetch and merge standard config files from one remote
# host/directory pair.
#
# Silently skips files that do not exist; warns (or logs) on parse errors.
# Merges into %$merged_ref using the same Hash::Merge LEFT_PRECEDENT strategy
# as the local pipeline, so remote values override earlier local values.
# ---------------------------------------------------------------------------
sub _load_remote_dir
{
	if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) {
		Carp::croak('Illegal Operation: This method can only be called by a subclass');
	}

	my ($self, $host, $remote_dir, $merged_ref, $file_list) = @_;
	my $logger = $self->{'logger'};

	unless($self->_load_driver('File::Slurp::Remote')) {
		my $msg = ref($self) . ": File::Slurp::Remote required for /../$host$remote_dir but is not installed";
		$logger ? $logger->warn($msg) : Carp::carp($msg);
		return;
	}

	# Use the same file list as the local pipeline (includes TOML and env-specific tiers).
	# Fall back to the legacy list if none was passed (e.g. from very old callers).
	my @files = $file_list ? @{$file_list}
		: qw(base.yaml base.yml base.json base.xml base.ini base.toml
		     local.yaml local.yml local.json local.xml local.ini local.toml);

	for my $file (@files) {
		my $remote_path = "/../$host$remote_dir/$file";

		if($logger) {
			$logger->debug(ref($self), ' ', __LINE__, ": Looking for remote config $remote_path");
		}

		my $raw = $self->_slurp_remote($host, "$remote_dir/$file");
		next unless defined($raw);

		if($logger) {
			$logger->debug(ref($self), ' ', __LINE__, ": Loading remote config $remote_path");
		}

		my $data = $self->_parse_config_string($raw, $file, $remote_path);
		next unless defined($data);

		if(ref($data) ne 'HASH') {
			my $msg = ref($self) . ": remote $remote_path did not yield a hash; skipping";
			$logger ? $logger->warn($msg) : Carp::carp($msg);
			next;
		}

		push @{$self->{'_source_records'}}, {
			type      => 'file',
			label     => $remote_path,
			flat_data => { _flatten_keys($data) },
		};
		%{$merged_ref} = %{ merge($data, $merged_ref) };
		push @{$merged_ref->{'config_path'}}, $remote_path;
	}
}

# ---------------------------------------------------------------------------
# _slurp_remote -- read a single file from a remote host via SSH.
#
# Wraps File::Slurp::Remote::read_file; returns the raw string on success
# or undef on any error (connection refused, file absent, permission denied).
# Errors are logged at debug level so missing files are not noisy.
# ---------------------------------------------------------------------------
sub _slurp_remote
{
	my ($self, $host, $path) = @_;
	my $logger = $self->{'logger'};

	# NOTE: verify the calling convention of your installed File::Slurp::Remote.
	# Common forms: read_file("$host:$path") or read_file($host, $path).
	my $content = eval { File::Slurp::Remote::read_file($host, $path) };

	if($@) {
		if($logger) {
			$logger->debug(ref($self), ' ', __LINE__, ": Could not read $path from $host: $@");
		}
		return undef;
	}
	return $content;
}

# ---------------------------------------------------------------------------
# _parse_config_string -- parse a raw config string by extension.
#
# Mirrors the format-detection logic used for local files.  INI content is
# written to a File::Temp scratch file because Config::IniFiles requires a
# real filesystem path; the temp file is removed as soon as parsing returns.
#
# Returns a hashref on success, undef on failure.
# ---------------------------------------------------------------------------
sub _parse_config_string
{
	if(!UNIVERSAL::isa((caller)[0], __PACKAGE__)) {
		Carp::croak('Illegal Operation: This method can only be called by a subclass');
	}

	my ($self, $raw, $filename, $label) = @_;
	my $logger = $self->{'logger'};
	my $data;

	eval {
		if($filename =~ /\.ya?ml$/i) {
			$self->_load_driver('YAML::XS', ['Load']);
			$data = YAML::XS::Load($raw);
			$data = $self->_sanitize_yaml_values($data) if defined($data) && ref($data);

		} elsif($filename =~ /\.json$/i) {
			$data = decode_json($raw);

		} elsif($filename =~ /\.xml$/i) {
			if($self->_load_driver('XML::Simple', ['XMLin'])) {
				if($raw !~ /<!ENTITY\s+\w+\s+(?:SYSTEM|PUBLIC)\b/i) {
					$data = XMLin(\$raw, ForceArray => 0, KeyAttr => []);
				}
			} elsif($self->_load_driver('XML::PP')) {
				my $pp = XML::PP->new();
				if(my $tree = $pp->parse(\$raw)) {
					$data = $pp->collapse_structure($tree);
					$data = $data->{'config'} if ($data && $data->{'config'});
				}
			}

		} elsif($filename =~ /\.ini$/i) {
			$self->_load_driver('Config::IniFiles');
			require File::Temp;
			my $tmp = File::Temp->new(SUFFIX => '.ini', UNLINK => 1);
			print {$tmp} $raw;
			$tmp->flush();
			if(my $ini = Config::IniFiles->new(-file => $tmp->filename())) {
				$data = { map {
					my $section = $_;
					$section => { map { $_ => $ini->val($section, $_) } $ini->Parameters($section) }
				} $ini->Sections() };
			}
		}
	};

	if($@) {
		my $err = $@;
		my $msg = ref($self) . ": Failed to parse $label: $err";
		$logger ? $logger->warn($msg) : Carp::carp($msg);
		return undef;
	}

	return $data;
}

sub AUTOLOAD
{
	our $AUTOLOAD;

	my $self = shift;
	my $key = $AUTOLOAD;