view release on metacpan or  search on metacpan

lib/Container/Buildah.pm  view on Meta::CPAN

	# collect debug parameters
	my %params;
	if (ref $in_args[0] eq "HASH") {
		my $params_ref = shift @in_args;
		%params = %$params_ref;
	}

	# print debugging statement if enabled
	my $level = $params{level} // 1;
	if ($debug >= $level) {
		my $wrapper = $params{wrapper} // 0; # skip stack frame if called from debug wrapper function

		# debug label: get caller name (default to function name from Perl call stack) and any label string
		my @label;
		if (exists $params{name} and defined $params{name}) {
			push @label, $params{name};
		} else {
			my $caller = (caller(1+$wrapper))[3];
			if ($caller eq "(eval)") {
				push @label, (caller(2+$wrapper))[3], "eval";
			} else {
				push @label, $caller;
			}
		}
		if (exists $params{label} and defined $params{label}) {
			push @label, $params{label};
		}

		# print debug message
		my $msg = "--- debug [".(join "/", @label)."]: ".join(" ", map {(defined $_) ? $_ : "(undef)"} @in_args);
		say STDERR $msg;
		if ((exists $cb->{oldstderr}) and ($cb->{oldstderr}->fileno != fileno(STDERR))) {
			$cb->{oldstderr}->print($msg."\n");
		}
	}
	return;
}

# template and variable expansion
# private class function
sub expand
{
	my $value = shift;
	my $cb = Container::Buildah->instance();

	# process array values sequentially
	if (ref $value eq "ARRAY") {
		my @result;
		foreach my $subvalue (@$value) {
			push @result, expand($subvalue);
		}
		$cb->debug({level => 4}, "expand: $value -> [".join(" ", @result)."]");
		return \@result;
	}

	# process scalar value
	my $output;
	$cb->{template}->process(\$value, $cb->{config}, \$output);
	$cb->debug({level => 4}, "expand: $value -> $output");

	# expand templates as long as any remain, up to 10 iterations
	my $count=0;
	while ($output =~ / \[% .* %\] /x and $count++ < 10) {
		$value = $output;
		$output = ""; # clear because template concatenates to it
		$cb->{template}->process(\$value, $cb->{config}, \$output);
		$cb->debug({level => 4}, "expand ($count): $value -> $output");
	}
	return $output;
}

# get configuration value
# public class method
sub get_config
{
	my ($class_or_obj, @path) = @_;
	my $cb = (ref $class_or_obj) ? $class_or_obj : $class_or_obj->instance();

	# special case for empty path: return config tree root
	if (not @path) {
		$cb->debug({level => 3}, "get_config: retrieved root node");
		return $cb->{config};
	}

	# navigate down config tree
	my $key = pop @path; # last entry of path is target node
	my $orig_path = join("/", @path)."->".$key; # for error reporting
	my $node = $cb->{config};
	while (@path) {
		my $subnode = shift @path;
		if (exists $node->{$subnode} and ref $node->{$subnode} eq "HASH") {
			$node = $node->{$subnode};
		} else {
			confess "get_config: ($subnode) not found in search for $orig_path";
		}
	}

	# return configuration
	if (exists $node->{$key}) {
		if (ref $node->{$key} and ref $node->{$key} ne "ARRAY") {
			$cb->debug({level => 3}, "get_config: $key -> $node->{$key}");
			return $node->{$key};
		}

		# if the value is scalar or array, perform variable expansion
		my $result = expand($node->{$key});
		if (ref $node->{$key} eq "ARRAY") {
			$cb->debug({level => 3}, "get_config: $key -> [".join(" ", @{$node->{$key}})."]");
		} else {
			$cb->debug({level => 3}, "get_config: $key -> $result");
		}
		return $result;
	}
	$cb->debug({level => 3}, "get_config: not found ($orig_path)");
	return;
}

# allow caller to enforce its required configuration
# public class method
sub required_config
{