view release on metacpan or  search on metacpan

lib/Carrot/Individuality/Controlled/Customized_Settings/Monad.pm  view on Meta::CPAN

package Carrot::Individuality::Controlled::Customized_Settings::Monad
# /type class
# /attribute_type ::Many_Declared::Ordered
# //parameters
#	inheritance  ::Modularity::Object::Inheritance::ISA_Occupancy
# /capability ""
{
	my ($inheritance) = @ARGUMENTS;

	use strict;
	use warnings 'FATAL' => 'all';

	my $expressiveness = Carrot::individuality;
	$expressiveness->provide(
		'::Individuality::Controlled::',
			my $class_names = '::Class_Names',
			my $distinguished_exceptions = '::Distinguished_Exceptions');

	$class_names->provide(
		my $cursor_class = '::Personality::Reflective::Iterate::Array::Cursor',
		'[=project_pkg=]::',
			my $line_class = '::Dot_Cfg::Line',
			my $source_class = '::Source::Here::Plain',
			my $dot_cdf_class = '::Dot_Cdf');

	$class_names->provide_instance(
		my $writable_overlay = '::Meta::Greenhouse::Writable_Overlay',
		my $compilation_name = '::Meta::Greenhouse::Compilation_Name');

	$distinguished_exceptions->provide(
		my $unsupported_data_type = 'unsupported_data_type',
		my $hash_element_missing = 'hash_element_missing');

	Carrot::Meta::Greenhouse::Package_Loader::provide_instance(
		my $loader = '::Modularity::Package::Loader');

# =--------------------------------------------------------------------------= #

sub attribute_construction
# /type method
# /effect "Constructs the attribute(s) of a newly created instance."
# //parameters
#	meta_monad  ::Meta::Monad
# //returns
{
	my ($this, $meta_monad) = @ARGUMENTS;

	my $package_file = $meta_monad->package_file;
	my $dot_directory = $package_file->dot_directory;
	my $default_settings = $dot_directory->entry('default_settings.cdf');
	$default_settings->consider_regular_content;

	my $compiled_settings = $dot_directory->entry(
		"default_settings-$$compilation_name.pl");
	$writable_overlay->redirect_read($compiled_settings);
	if ($default_settings->modification_timestamp_is_newer($compiled_settings))
	{
	# NOTE: manually setting @ARGUMENTS copies but doesn't alias them
		@ARGUMENTS = ($loader, \$this->[ATR_VALUES]);
		require($compiled_settings->value);
		$this->[ATR_ARE_MODIFIED] = IS_FALSE;
		return;
	}
	$this->[ATR_ARE_MODIFIED] = IS_TRUE;

	my $these_values = $this->[ATR_VALUES] = {};

	my $dot_cdf = $dot_cdf_class->indirect_constructor(
		$meta_monad->class_names,
		$default_settings);
##	$this->[ATR_DEFINER] = $dot_cdf;
	$dot_cdf->definition($these_values);

	my $independent = IS_TRUE;
	my $occupied = $inheritance->collect_occupied(
		$meta_monad->parent_classes->perl_isa);
	foreach my $that (reverse(@$occupied))
	{
		my $those_values = $that->[ATR_VALUES];
#FIXME: the behaviour should be documented - different from ->inherit
		foreach my $key (keys($those_values))
		{
			$independent = IS_FALSE;
			next if (exists($these_values->{$key}));
			$these_values->{$key} =
				$those_values->{$key}->clone_constructor;
		}
	}

	if ($independent) # just because it could be newer?
	{
		require Data::Dumper;
		my $dumper = Data::Dumper->new([$these_values]);
		$dumper->Indent(1);

		my $dumped = $dumper->Dump; #($these_values);
		my $pkg_names = [$dumped =~ m{(?:\n +\]|\)\}), '([^\n\']+)' \),?\n}sg];
		@$pkg_names = keys({map(($_ => 1), @$pkg_names)});

		my $datetime = scalar(gmtime(time()));
		my $pkg_name = $meta_monad->package_name->value;
		my $perl_code =
			"# Automatically created on $datetime GMT.\n"
			."# Manual changes will get lost.\n"
			."# package $pkg_name\n"
#			"use strict;\n"
#			. "use warnings;\n"
			. join("\n", map("\$_[0]->load('$_');", @$pkg_names))
			. "\n\${\$_[1]} = my "
			. $dumped
			. "\nreturn(1);";

		$writable_overlay->redirect_write($compiled_settings);
		$compiled_settings->consider_regular_content;
		$compiled_settings->overwrite_from($perl_code);
	}
	return;
}

sub are_modified
# /type method
# /effect ""
# //parameters
# //returns
#	?
{
	return($_[THIS][ATR_ARE_MODIFIED]);
}

sub clone_constructor
# /type method
# /effect ""
# //parameters
# //returns
#	?
{
	my ($this) = @ARGUMENTS;

	my $cloned_values = {};
	keys($this->[ATR_VALUES]); # reset 'each' iterator
	while (my ($key, $value) = each($this->[ATR_VALUES]))
	{
		$cloned_values->{$key} = $value->clone_constructor;
	}
	my $clone = [
#		$this->[ATR_DEFINER],
		$cloned_values]	;
	bless($clone, $this->class_name);
	$clone->lock_attribute_structure;

	return($clone);
}

#FIXME: this ended up as a convenience method
sub further_customized
# /type method
# /effect ""
# //parameters
#	raw_settings
# //returns
#	?
{
	my $clone = $_[THIS]->clone_constructor;

	unless (defined($_[SPX_RAW_SETTINGS]))
	{
		return($clone);
	}
	my $type = ref($_[SPX_RAW_SETTINGS]);
	if ($type eq '')
	{
		$clone->customize_by_scalar($_[SPX_RAW_SETTINGS]);