view release on metacpan or  search on metacpan

lib/Carrot/Meta/Greenhouse/Writable_Overlay.pm  view on Meta::CPAN

package Carrot::Meta::Greenhouse::Writable_Overlay
# /type class
# //parent_classes
#	[=parent_pkg=]
# /capability "Redirect file access to a writeable directory."
{
	use strict;
	use warnings 'FATAL' => 'all';
	use open qw(:encoding(utf8));

	BEGIN {
		require('Carrot/Meta/Greenhouse/Writable_Overlay./manual_modularity.pl');
	} #BEGIN

#	Carrot::Meta::Greenhouse::Package_Loader::provide_instance(
#		my $file_content = '::Meta::Greenhouse::File_Content',
#		my $compilation_name = '::Meta::Greenhouse::Compilation_Name',
#		my $fatal_syscalls = '::Meta::Greenhouse::Fatal_Syscalls',
#		my $translated_errors = '::Meta::Greenhouse::Translated_Errors');

	require Carrot::Meta::Greenhouse::File_Content;
	my $file_content = Carrot::Meta::Greenhouse::File_Content->constructor;

	require Carrot::Meta::Greenhouse::Compilation_Name;
	my $compilation_name = Carrot::Meta::Greenhouse::Compilation_Name->constructor;

	require Carrot::Meta::Greenhouse::Fatal_Syscalls;
	my $fatal_syscalls = Carrot::Meta::Greenhouse::Fatal_Syscalls->constructor;

	require Carrot::Meta::Greenhouse::Translated_Errors;
	my $translated_errors = Carrot::Meta::Greenhouse::Translated_Errors->constructor;

	my $cache = "$ENV{'HOME'}/.carrot/writable_overlay/$$compilation_name";
	my $cache_fnl = length($cache);
	my $index_file = "$cache.idx";
	my $index = {};
	my $xedni = {};
	my $highest_id = 0;
	my $prefix = '';
	my $prefix_fnl = 1;

	if (REDIRECT_FLAG) {
		unless (-e $cache)
		{
			$fatal_syscalls->mkdir($cache);
		}
		unless (-w $cache)
		{
			$translated_errors->advocate(
				'file_not_writable',
				[$cache]);
		}

		if (-f $index_file)
		{
			read_index();
		} else {
			create_index();
		}
	}

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

sub read_index
# /type method
# /effect ""
# //parameters
#	file_name
# //returns
{
	my $lines = $file_content->read_lines($index_file);
	my $deleted = 0;
	pop($lines);
	foreach my $line (@$lines)
	{
		if($line =~ m{\A#}saa)
		{
			next;

		} elsif ($line eq '')
		{
			$prefix = '';
			$prefix_fnl = 1;

		} elsif ($line =~ m{\A/}saa)
		{
			$prefix = $line;
			$prefix_fnl = length($prefix);

		} elsif ($line =~ m{\A((\d{8})\.\w+)\t(.*)\z}saa)
		{
			my ($redirected, $id, $logical) = ($1, $2, $3);
			if ($logical eq '-')