# HG changeset patch
# User sergey
# Date 1359722279 -14400
# Node ID 6585464c4664af7bfae48eb3e4b152505f04bc6e
# Parent  8a5da17d7ef938437236e362f882bc837558aea2
sync (unstable)

diff -r 8a5da17d7ef9 -r 6585464c4664 Lib/IMPL/Class/Member.pm
--- a/Lib/IMPL/Class/Member.pm	Thu Jan 31 17:37:44 2013 +0400
+++ b/Lib/IMPL/Class/Member.pm	Fri Feb 01 16:37:59 2013 +0400
@@ -1,12 +1,11 @@
 package IMPL::Class::Member;
 use strict;
 use parent qw(Exporter);
-our @EXPORT = qw(virtual public private protected);
+our @EXPORT = qw(&public &private &protected);
 
 
 use IMPL::Const qw(:access);
 
-use IMPL::Class::Meta;
 require IMPL::Class::MemberInfo;
 
 sub public($) {
@@ -29,4 +28,5 @@
     my ($class,$implementor) = delete $info->{'class','-implementor'};
     $class->$implementor($info);
 }
+
 1;
diff -r 8a5da17d7ef9 -r 6585464c4664 Lib/IMPL/Class/Property/Base.pm
--- a/Lib/IMPL/Class/Property/Base.pm	Thu Jan 31 17:37:44 2013 +0400
+++ b/Lib/IMPL/Class/Property/Base.pm	Fri Feb 01 16:37:59 2013 +0400
@@ -106,14 +106,6 @@
     1;
 }
 
-sub Implement {
-    my ($self, $name, $spec) = @_;
-    
-    {
-    	name => 
-    }
-}
-
 # extract from property info: class, name, get_accessor, set_accessor, validator
 sub RemapFactoryParams {
     my ($self,$propInfo) = @_;
diff -r 8a5da17d7ef9 -r 6585464c4664 Lib/IMPL/Code/BasePropertyImplementor.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Code/BasePropertyImplementor.pm	Fri Feb 01 16:37:59 2013 +0400
@@ -0,0 +1,134 @@
+package IMPL::Code::BasePropertyImplementor;
+use strict;
+
+use IMPL::Const qw(:prop :access);
+
+use constant {
+	CodeNoGetAccessor => 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;',
+    CodeNoSetAccessor => 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;',
+    CodeCustomGetAccessor => 'unshift @_, $this and goto &$get;',
+    CodeCustomSetAccessor => 'unshift @_, $this and goto &$set;',
+    CodeValidator => '$this->$validator(@_);',
+    CodeOwnerCheck => "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"
+};
+
+sub CodeSetAccessor {
+    die new IMPL::Exception("Standard accessors not supported",'Set');
+}
+    
+sub CodeGetAccessor {
+    die new IMPL::Exception("Standard accessors not supported",'Get');
+}
+
+sub CodeGetListAccessor {
+    die new IMPL::Exception("Standard accessors not supported",'GetList');
+}
+
+sub CodeSetListAccessor {
+    die new IMPL::Exception("Standard accessors not supported",'SetList');
+}
+
+sub factoryParams { qw($class $name $set $get $validator) };
+
+our %ACCESS_CODE = (
+    ACCESS_PUBLIC , "",
+    ACCESS_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
+    ACCESS_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" 
+);
+
+sub NormalizeSpecification {
+	my ($this,$spec) = @_;
+	
+	return ref $spec
+        ? $spec
+        : {
+            get => $spec & PROP_GET,
+            set => $spec & PROP_SET,
+            isList => $spec & PROP_LIST,
+            ownerSet => $spec & PROP_OWNERSET
+        };	    
+}
+
+sub CreateFactoryId {
+	my ($self, $spec) = @_;
+	
+	join( '',
+        map(
+            $_
+                ? ref $_ eq 'CODE'
+                    ? 'x'
+                    : 's'
+                : '_',
+            @$spec{qw(get set)}
+        ),
+        $spec->{access},
+        $spec->{validator} ? 'v' : '_',
+        $spec->{isList} ? 'l' : '_',
+        $spec->{ownerSet} ? 'o' : '_'
+    );
+}
+
+sub CreateFactory {
+	my ($self,$spec) = @_;
+	
+	return $self->CreateFactoryImpl(
+        $spec->{get}
+            ? ref $spec->{get} eq 'CODE'
+                ? $self->CodeCustomGetAccessor
+                : $spec->{isList}
+                    ? $spec->CodeGetListAccessor
+                    : $spec->CodeGetAccessor
+            : $spec->CodeNoGetAccessor,
+        $spec->{set}
+            ? ref $spec->{set} eq 'CODE'
+                ? $self->CodeCustomSetAccessor
+                : $spec->{isList}
+                    ? $spec->CodeSetListAccessor
+                    : $spec->CodeSetAccessor
+            : $spec->CodeNoSetAccessor,
+        $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '',
+        $spec->{validator} ? $self->CodeValidator : '',
+        $spec->{ownerSet} ? $self->CodeOwnerCheck : ''
+	);
+}
+
+sub CreateFactoryImpl {
+    my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_;
+    
+    my $strParams = join(',',$self->factoryParams);
+    
+    my $factory = <<FACTORY;
+    
+sub {
+    my ($strParams) = \@_;
+    my \$accessor;
+    \$accessor = sub {
+        my \$this = shift;
+        $codeAccessCheck
+        if (\@_) {
+            $codeOwnerCheck
+            $codeValidator
+            $codeSet
+        } else {
+            $codeGet
+        }
+    }
+}
+FACTORY
+
+    return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
+}
+
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C<IMPL::Code::BasePropertyImplementor> набор впомогательныйх статических методов
+для генерации свойств.
+
+=cut
\ No newline at end of file
diff -r 8a5da17d7ef9 -r 6585464c4664 Lib/IMPL/Code/DirectPropertyImplementor.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Code/DirectPropertyImplementor.pm	Fri Feb 01 16:37:59 2013 +0400
@@ -0,0 +1,62 @@
+package IMPL::Code::DirectPropertyImplementor;
+use strict;
+
+use IMPL::require {
+	Exception => 'IMPL::Exception',
+	ArgException => '-IMPL::InvalidArgumentException'
+};
+
+use parent qw(IMPL::Code::BasePropertyImplementor);
+
+use constant {
+	CodeGetAccessor => 'return ($this->{$field});',
+	CodeSetAccessor => 'return ($this->{$field} = $_[0])',
+	CodeGetListAccessor => 'return(
+        wantarray ?
+        @{ $this->{$field} ?
+            $this->{$field} :
+            ( $this->{$field} = IMPL::Object::List->new() )
+        } :
+        ( $this->{$field} ?
+            $this->{$field} :
+            ( $this->{$field} = IMPL::Object::List->new() )
+        )
+    );',
+    CodeSetListAccessor => 'return(
+        wantarray ?
+        @{ $this->{$field} = IMPL::Object::List->new(
+            (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]  
+        )} : 
+        ($this->{$field} = IMPL::Object::List->new(
+            (@_ == 1 and UNIVERSAL::isa($_[0], \'ARRAY\') ) ? $_[0] : [@_]  
+        ))
+    );'
+};
+
+sub factoryParams { qw($class $name $set $get $validator $field) };
+
+my %cache;
+
+sub Implement {
+	my ($self, $spec) = @_;
+	
+	my $name = $spec->{name}
+        or ArgException->new(name => "The name of the property is required");
+    my $class = $spec->{class}
+        or ArgException->new(name => "The onwer class must be specified");
+	
+	$spec = $self->NormalizeSpecification($spec);
+	
+	my $id = $self->CreateFactoryId($spec);
+	my $factory = $cache{$id};
+	unless($factory) {
+        $factory = $self->CreateFactory($spec);
+        $cache{$id} = $factory;		
+	}
+	
+	
+	
+	
+}
+
+1;
\ No newline at end of file