diff Lib/IMPL/Class/Property/Base.pm @ 59:0f3e369553bd

Rewritten property implementation (probably become slower but more flexible) Configuration infrastructure in progress (in the aspect of the lazy activation) Initial concept for the code generator
author wizard
date Tue, 09 Mar 2010 02:50:45 +0300
parents
children b0c068da93ac
line wrap: on
line diff
--- /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