package IMPL::Class::Property::Base;
use strict;

use IMPL::Class::Property;

require IMPL::Class::Member;

our @factoryParams = qw($class $name $set $get $validator);

my %factoryCache;

my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;';
my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;';

my $custom_accessor_get = 'unshift @_, $this and goto &$get;';
my $custom_accessor_set = 'unshift @_, $this and goto &$set;';

my $validator_code = '$this->$validator(@_);'; 

my %access_code = (
	IMPL::Class::Member::MOD_PUBLIC , "",
	IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
	IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" 
);

my $virtual_call = q(
		my $method = $this->can($name);
        return $this->$method(@_) unless $method == $accessor or caller->isa($class);
);

my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;";

sub GenerateAccessors {
	my ($self,$param,@params) = @_;
	
	my %accessors;
	
	if (not ref $param) {
		if ($param & prop_list) {
			$accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : $accessor_get_no;
			$accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : $accessor_set_no;
		} else {
			$accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : $accessor_get_no;
			$accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : $accessor_set_no;
		}
		$accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : "";
	} elsif (UNIVERSAL::isa($param,'HASH')) {
		$accessors{get} = $param->{get} ? $custom_accessor_get : $accessor_get_no;
		$accessors{set} = $param->{set} ? $custom_accessor_set : $accessor_set_no;
		$accessors{owner} = "";
	} else {
		die new IMPL::Exception('The unsupported accessor/mutators supplied',$param);
	}
	
	return \%accessors;
}

sub GenerateSet {
	die new IMPL::Exception("Standard accessors not supported");
}
	
sub GenerateGet {
	die new IMPL::Exception("Standard accessors not supported");
}

sub GenerateGetList {
	die new IMPL::Exception("Standard accessors not supported");
}

sub GenerateSetList {
	my ($self) = @_;
	die new IMPL::Exception("Standard accessors not supported");
}

sub Make {
	my ($self,$propInfo) = @_;
	
	my $key = $self->MakeFactoryKey($propInfo);
	
	my $factory = $factoryCache{$key};
	
	unless ($factory) {
		my $mutators = $self->GenerateAccessors($propInfo->Mutators);
		$factory = $self->CreateFactory(
			$access_code{ $propInfo->Access },
			$propInfo->Attributes->{validator} ? $validator_code : "",
			$mutators->{owner},
			$mutators->{get},
			$mutators->{set}
		);
		$factoryCache{$key} = $factory; 
	}
	
	{
		no strict 'refs';
		*{ $propInfo->Class.'::'.$propInfo->Name } = &$factory($self->RemapFactoryParams($propInfo));
	}
	
	my $mutators = $propInfo->Mutators;
	
	if (ref $mutators) {
		$propInfo->canGet( $mutators->{get} ? 1 : 0 );
		$propInfo->canSet( $mutators->{set} ? 1 : 0 );
	} else {
		$propInfo->canGet( $mutators & prop_get );
		$propInfo->canSet( $mutators & prop_set );
	}
}

# extract from property info: class, name, get_accessor, set_accessor, validator
sub RemapFactoryParams {
	my ($self,$propInfo) = @_;
	
	my $mutators = $propInfo->Mutators;
	my $class = $propInfo->Class;
	my $validator = $propInfo->Attributes->{validator};
	
	die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator);

	return (
		$propInfo->get(qw(Class Name)),
		(ref $mutators?
			($mutators->{set},$mutators->{get})
			:
			(undef,undef)
		),
		$validator
	);
}

sub MakeFactoryKey {
	my ($self,$propInfo) = @_;
	
	my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator});
	
	return join ('',
		$access,
		$validator ? 'v' : 'n',
		ref $mutators ?
			('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0)
			:
			(($mutators & prop_list) ? 'l' : 's' , ($mutators & prop_get) ? 1 : 0, ($mutators & prop_set) ? ((($mutators & owner_set) == owner_set) ? 2 : 1 ) : 0 ) 
	); 
}

sub CreateFactory {
	my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_;
	
	my $strParams = join(',',@factoryParams);
	
	my $factory = <<FACTORY;
	
sub {
    my ($strParams) = \@_;
    my \$accessor;
    \$accessor = sub {
        my \$this = shift;
        $codeAccessCheck
        $codeValidator
        if (\@_) {
        	$codeOwnerCheck
        	$codeSet
        } else {
        	$codeGet
        }
    }
}
FACTORY

	return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
}

1;

__END__

=pod

=head1 DESCRIPTION

Базовый класс для реализации свойств.

По существу свойства состоят из двух методов для установки и получения значений. Также
существует несколько вариантов доступа к свойству, и метод верификации значения. Еще
свойства могут быть виртуальными.

Для создания реализатора свойств достаточно унаследовать от этого класса и описать
методы для генерации кода получения и установки значения. 

=cut