File Coverage

blib/lib/Config/ReadAndCheck.pm

Criterion	Covered	Total	%
statement	15	162	9.2
branch	0	82	0.0
condition	0	12	0.0
subroutine	5	17	29.4
pod	9	9	100.0
total	29	282	10.2

package Config::ReadAndCheck;

use strict;

#$^W++;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

require Exporter;

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
);

%EXPORT_TAGS = ('print' => [qw(PrintList)],
               );

foreach (keys(%EXPORT_TAGS))
        { push(@{$EXPORT_TAGS{'all'}}, @{$EXPORT_TAGS{$_}}); };

$EXPORT_TAGS{'all'}
	and @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

@EXPORT = qw(
);

$VERSION = '0.04';

use Carp;
use IO::File;
use Tie::IxHash;

my $CheckLoop = undef;
$CheckLoop = sub
	{
	my ($Params, $Dupes, $Path) = @_;
	if (!($Dupes && $Path))
		{
		$Dupes = {};
		$Path  = 'root'
		};
	my $Name = undef;
	foreach $Name (keys(%{$Params}))
		{
		if ($Params->{$Name}->{'SubSection'})
			{
			if (exists($Dupes->{$Params->{$Name}->{'SubSection'}}))
				{
				$@ = "SubSection loop found: \"$Path\->$Name\"";
				return 1;
				};
			$Dupes->{$Params->{$Name}->{'SubSection'}}++;
			if (&{$CheckLoop}($Params->{$Name}->{'SubSection'}, $Dupes, "$Path\->$Name"))
				{ return 1; };
			delete($Dupes->{$Params->{$Name}->{'SubSection'}});
			};
		};
	return 0;
	};

my $CheckParams = undef;
$CheckParams = sub
	{
	my ($Params, $Path) = @_;

	my $NewParams = undef;
	tie(%{$NewParams}, 'Tie::IxHash');

	($Path) or $Path = 'root';

	my $SimpleProcess = sub() { return ($1, $2); };

	my $Name = undef;
	foreach $Name (keys(%{$Params}))
		{
		if (ref($Params->{$Name}) ne 'HASH')
			{
			$@ = "\"$Path\->$Name\" have to be a 'HASH' reference!";
			#if($^W) { Carp::carp $@; };
			return;
			};

		if (!defined($Params->{$Name}->{'Pattern'}))
			{
			$@ = "\"$Path\->$Name\->{'Pattern'}\" have to be defined!";
			#if($^W) { Carp::carp $@; };
			return;
			};

		$NewParams->{$Name}->{'Pattern'} = $Params->{$Name}->{'Pattern'};

		$NewParams->{$Name}->{'Type'} = $Params->{$Name}->{'Type'}
			or $NewParams->{$Name}->{'Type'} = 'UNIQ';
		$NewParams->{$Name}->{'Type'} = uc($NewParams->{$Name}->{'Type'});

		if (!(($NewParams->{$Name}->{'Type'} eq 'UNIQ')     ||
		      ($NewParams->{$Name}->{'Type'} eq 'LIST')     ||
		      ($NewParams->{$Name}->{'Type'} eq 'UNIQLIST') ||
		      ($NewParams->{$Name}->{'Type'} eq 'IGNORE')))
			{
			$@ = "$Path\->$Name\->{'Type'} have to be 'UNIQ', or 'LIST', or 'UNIQLIST', or 'IGNORE'!";
			#if($^W) { Carp::carp $@; };
			return;
			};

		$NewParams->{$Name}->{'Process'} = $Params->{$Name}->{'Process'}
			or $NewParams->{$Name}->{'Process'} = $SimpleProcess;

		if (ref($NewParams->{$Name}->{'Process'}) ne 'CODE')
			{
			$@ = "$Path\->$Name\->{'Process'} have to be a 'CODE' reference!";
			#if($^W) { Carp::carp $@; };
			return;
			};

		(!exists($Params->{$Name}->{'Default'}))
			or $NewParams->{$Name}->{'Default'} = $Params->{$Name}->{'Default'};

		defined($Params->{$Name}->{'SubSection'})
			or next;

		if (ref($Params->{$Name}->{'SubSection'}) ne 'HASH')
			{
			$@ = "$Path\->$Name\->{'SubSection'} have to be reference to 'HASH'!";
			#if($^W) { Carp::carp $@; };
			return;
			};

		$NewParams->{$Name}->{'SubSection'} = &{$CheckParams}($Params->{$Name}->{'SubSection'}, "$Path\->$Name")
			or return;
		};
	return $NewParams;
	};

sub new($%)
	{
	my ($class, %Config) = @_;

	(!&{$CheckLoop}($Config{'Params'}))
		or return;

	my $self = {};

	$self->{'CaseSens'} = $Config{'CaseSens'};

	$self->{'Params'} = &{$CheckParams}($Config{'Params'})
		or return;

	Reset($self);

	return bless $self => $class;
	};

sub Result($)
	{
	my ($self) = @_;
	my %Result = ();
	tie(%Result, 'Tie::IxHash', %{$self->{'Result'}});
	return (wantarray ? %Result : \%Result);
	};

sub Reset($)
	{
	my ($self) = @_;
        tie(%{$self->{'Result'}}, 'Tie::IxHash');
	$self->{'SecStack'} = [];
	unshift(@{$self->{'SecStack'}}, {'Params' => $self->{'Params'},'Result' => $self->{'Result'}});
	};

sub Params($)
	{
	my ($self) = @_;
	my $Params = &{$CheckParams}($self->{'Params'});
	return (wantarray ? %{$Params} : $Params);
	};

my $ParseLine = sub($$)
	{
	my ($self, $Str, $Params) = @_;

	my $Name = undef;

	#print "###########################\n".PrintList($Params, 'p: ', '  ');

	foreach $Name (keys(%{$Params}))
		{
		my $Pattern = $Params->{$Name}->{'Pattern'};

		my ($P1, $P2);
		($self->{'CaseSens'} ? $Str =~ m/\A$Pattern\Z/ : $Str =~ m/\A$Pattern\Z/i)
			or next;
		$@ = '';
		if (!(($P1, $P2) = &{$Params->{$Name}->{'Process'}}()))
			{
			length($@)
				or $@ = "Invalid value(s) in '$Name' definition";
			#if($^W) { Carp::carp $@; };
			return;
			};
		return ($Name, $P1, $P2);
		};

	$@ = "Unrecognized string";
	#if($^W) { Carp::carp $@; };
	return;
	};

my $CheckRequired = undef;
$CheckRequired = sub
	{
	my ($Params, $Result, $Path) = @_;

	defined($Path)
		or $Path = 'root';

	my $Key = undef;
	foreach $Key (keys(%{$Params}))
		{
		($Params->{$Key}->{'Type'} ne 'IGNORE')
			or next;
		if (!exists($Result->{$Key}))
			{
			if (!exists($Params->{$Key}->{'Default'}))
				{
				$@ = "Required parameter $Path\->$Key is not defined";
				#if($^W) { Carp::carp $@; };
				return;
				};

			if    ($Params->{$Key}->{'Type'} eq 'LIST')
				{
				if (ref($Params->{$Key}->{'Default'}) ne 'ARRAY')
					{
					$@ = "$Path\->$Key\->{'Default'} have to be an 'ARRAY' reference";
					#if($^W) { Carp::carp $@; };
					return;
					};
				@{$Result->{$Key}} = @{$Params->{$Key}->{'Default'}};
				}
			elsif ($Params->{$Key}->{'Type'} eq 'UNIQLIST')
				{
				if (ref($Params->{$Key}->{'Default'}) ne 'HASH')
					{
					$@ = "$Path\->$Key\->{'Default'} have to be a 'HASH' reference";
					#if($^W) { Carp::carp $@; };
					return;
					};
				tie(%{$Result->{$Key}}, 'Tie::IxHash', %{$Params->{$Key}->{'Default'}});
				}
			else
				{ $Result->{$Key} = $Params->{$Key}->{'Default'}; };
			};
		if ($Params->{$Key}->{'SubSection'})
			{
			#print "$Path\->$Key\->{'SubSection'}\n";
			my @SubResults = ();

			if    ($Params->{$Key}->{'Type'} eq 'UNIQ')
				{ $SubResults[0] = $Result->{$Key}; }
			elsif ($Params->{$Key}->{'Type'} eq 'LIST')
				{ @SubResults = @{$Result->{$Key}}; }
			elsif ($Params->{$Key}->{'Type'} eq 'UNIQLIST')
				{ @SubResults = values(%{$Result->{$Key}}); };

			my $SubResult = undef;
			foreach $SubResult (@SubResults)
				{
				if (ref($SubResult) ne 'HASH')
					{
					$@ = "Value of parameter $Path\->$Key have to be a 'HASH' reference because of 'SubSection' defined for it";
					#if($^W) { Carp::carp $@; };
					return;
					};
				&{$CheckRequired}($Params->{$Key}->{'SubSection'}, $SubResult, "$Path\->$Key")
					or return;
				};
			};
		};

	return (wantarray ? %{$Result} : $Result);
	};

sub CheckRequired($)
	{
	my ($self);
	($self) = @_;

	my %Result = ();
	tie(%Result, 'Tie::IxHash');
	%Result = &{$CheckRequired}($self->{'Params'}, $self->{'Result'})
		or return;
	return (wantarray ? %Result : \%Result);
	};

my $ParseGetline = sub($$)
	{
	my ($self, $GetLine) = @_;

	my $Line = 0;
	my $Str = undef;
	while ($Str = &{$GetLine}())
		{
		$Line++;
		$Str =~ s/\n//g;

		if (!ParseIncremental($self, $Str))
			{
			$@ = "$@, line $Line: \"$Str\"";
			#if($^W) { Carp::carp $@; };
			return;
			};
		defined($self->{'SecStack'}->[0])
			or last;
		};

	if ($self->{'Params'}->{'EndOfSection'} &&
	    $self->{'SecStack'}->[0])
		{
		$@ = "Input dry up before 'EndOfSection' reached";
		return;
		};

	CheckRequired($self)
		or return;

	return (wantarray ? %{$self->{'Result'}} : $self->{'Result'});
	};

sub Parse($$)
	{
	my ($self, $Input) = @_;
	my $GetLine  = undef;
	my $RunIndex = 0;
	if    (!ref($Input))
		{
		my @tmpArray = split('\n', $Input);
		$Input = \@tmpArray;
		$GetLine = sub{return $Input->[$RunIndex++]};
		}
	elsif (ref($Input) eq 'CODE')
		{
		$GetLine = $Input;
		}
	elsif (ref($Input) eq 'ARRAY')
		{
		$GetLine = sub{return $Input->[$RunIndex++]};
		}
	else
		{
		$@ = "Can not use reference to ".ref($Input)." as an input source";
		return;
		};

	my %Result = ();
	tie(%Result, 'Tie::IxHash');
	%Result = &{$ParseGetline}($self, $GetLine)
		or return;

	return (wantarray ? %Result : \%Result);
	};

sub ParseFile($$)
	{
	my ($self, $FileName) = @_;

	my $File = IO::File->new("< $FileName");
	if (!$File)
		{
		$@ = "Can not open file \"$FileName\" for read";
		return;
		};

	my %Result = ();
	tie(%Result, 'Tie::IxHash');
	%Result = &{$ParseGetline}($self, sub{return $File->getline()})
		or return;

	$File->close();

	return (wantarray ? %Result : \%Result);
	};

my $UnshiftSubSecIfNecessary = sub
	{
	my ($self, $Params, $Result) = @_;

	if (!tied(%{$Result}))
		{
		tie(%{$Result}, 'Tie::IxHash', %{$Result});
		$_[2] = $Result;
		};

	unshift(@{$self->{'SecStack'}}, {'Params' => $Params, 'Result' => $Result});

	return $Params;
	};

sub ParseIncremental($$)
	{
	my ($self, $Str) = @_;

	my ($Name, $P1, $P2);

	my $Params = undef;
	while($Params = $self->{'SecStack'}->[0]->{'Params'})
		{
		(!(($Name, $P1, $P2) = &{$ParseLine}($self, $Str, $Params)))
			or last;

		(!defined($Params->{'EndOfSection'}))
			or return;

		shift(@{$self->{'SecStack'}})
		};

	defined($Name)
		or return;

	#print "$Name, $P1, $P2\n";

	my $Type   = $Params->{$Name}->{'Type'};
	my $Result = $self->{'SecStack'}->[0]->{'Result'};

	if    ($Type eq 'UNIQ')
		{
		if (exists($Result->{$Name}))
			{
			$@ = "Duplicate '$Name' definition";
			#if($^W) { Carp::carp $@; };
			return;
			};

		$Result->{$Name} = $P1;

		if (defined($Params->{$Name}->{'SubSection'}))
			{
			if (defined($Result->{$Name}) && (ref($Result->{$Name}) ne 'HASH'))
				{
				print $Result->{$Name}.', '.ref($Result->{$Name})."\n";
				$@ = "{'$Name'}->{'Process'} have to return refrence to 'HASH' because of {'$Name'}->{'SubSection'} property is defined";
				return;
				}
			else
				{
				&{$UnshiftSubSecIfNecessary}($self, $Params->{$Name}->{'SubSection'}, $Result->{$Name});
				};

			};
		}
	elsif ($Type eq 'LIST')
		{
		(ref($Result->{$Name}) eq 'ARRAY')
			or $Result->{$Name} = [];

		push(@{$Result->{$Name}}, $P1);

		if (defined($Params->{$Name}->{'SubSection'}))
			{
			if (defined($Result->{$Name}->[$#{$Result->{$Name}}]) &&
			    (ref($Result->{$Name}->[$#{$Result->{$Name}}]) ne 'HASH'))
				{
				print $Result->{$Name}->[$#{$Result->{$Name}}].', '.ref($Result->{$Name}->[$#{$Result->{$Name}}])."\n";
				$@ = "{'$Name'}->{'Process'} have to return refrence to 'HASH' because of {'$Name'}->{'SubSection'} property is defined";
				return;
				}
			else
				{
				&{$UnshiftSubSecIfNecessary}($self, $Params->{$Name}->{'SubSection'}, $Result->{$Name}->[$#{$Result->{$Name}}]);
				};

			};
		}
	elsif ($Type eq 'UNIQLIST')
		{
		#print "$Name'->'$P1': \"$Result->{$Name}->{$P1}\"\n";
		if (ref($Result->{$Name}) ne 'HASH')
			{
			$Result->{$Name} = undef;
			tie(%{$Result->{$Name}}, 'Tie::IxHash');
			};

		if (!defined($P1))
			{
			$@ = "{'$Name'}->{'Process'} have to return defined value as a first element of the list";
			return;
			};

		if (exists($Result->{$Name}->{$P1}))
			{
			$@ = "Duplicate '$Name'->'$P1' definition";
			$@ .= ", the value is \"$Result->{$Name}->{$P1}\"";
			#if($^W) { Carp::carp $@; };
			return;
			};

		$Result->{$Name}->{$P1} = $P2;

		if (defined($Params->{$Name}->{'SubSection'}))
			{
			if (defined($Result->{$Name}->{$P1}) && (ref($Result->{$Name}->{$P1}) ne 'HASH'))
				{
				$@ = "{'$Name'}->{'Process'} have to return refrence to 'HASH' because of {'$Name'}->{'SubSection'} property is defined";
				return;
				}
			else
				{
				&{$UnshiftSubSecIfNecessary}($self, $Params->{$Name}->{'SubSection'}, $Result->{$Name}->{$P1});
				};

			};
		};

	($Name ne 'EndOfSection')
		or shift(@{$self->{'SecStack'}});

	return $Name;
	};


my $SafeStr = sub($)
	{
	my ($Str) = shift
		or return '!UNDEF!';
	$Str =~ s{ ([\x00-\x1f\xff]) } { sprintf("\\x%2.2X", ord($1)) }gsex;
	return $Str;
	};

sub PrintList
	{
	my ($List, $Pref, $Shift) = @_;

	if    (!(ref($List) eq 'ARRAY' || (ref($List) eq 'HASH')))
		{
		$@ = "First parameter have to be ARRAY or HASH reference!";
		if ($^W) { Carp::carp("$@\n"); };
		return;
		};

	my $Res = '';

	my $RunIndex = 0;
	my $Name = undef;
	foreach $Name ((ref($List) eq 'ARRAY') ? @{$List} : keys(%{$List}))
		{
		my $Key = (ref($List) eq 'ARRAY') ? "[$RunIndex]" : "'$Name'";
		my $Val = (ref($List) eq 'ARRAY') ? $Name      : $List->{$Name};
		my $Dlm = (ref($List) eq 'ARRAY') ? '= '       : '=>';
		if    (ref($Val) eq 'ARRAY')
			{ $Res .= sprintf("%s%s array\n%s",  $Pref, &{$SafeStr}($Key), PrintList($Val, $Pref.$Shift, $Shift)); }
		elsif (ref($Val) eq 'HASH')
			{ $Res .= sprintf("%s%s hash\n%s",   $Pref, &{$SafeStr}($Key), PrintList($Val, $Pref.$Shift, $Shift)); }
		else
			{ $Res .= sprintf("%s%s\t%s %s\n",   $Pref, &{$SafeStr}($Key), $Dlm, (defined($Val) ? '"'.&{$SafeStr}($Val).'"' : 'undef')); }
		$RunIndex++;
		};

	return $Res;
	};

1;
__END__