--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Class/Property/Base.pm	Tue Mar 09 02:50:45 2010 +0300
@@ -0,0 +1,190 @@
+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
\ No newline at end of file