Mercurial > pub > Impl
changeset 277:6585464c4664
sync (unstable)
author | sergey |
---|---|
date | Fri, 01 Feb 2013 16:37:59 +0400 |
parents | 8a5da17d7ef9 |
children | 4ddb27ff4a0b |
files | Lib/IMPL/Class/Member.pm Lib/IMPL/Class/Property/Base.pm Lib/IMPL/Code/BasePropertyImplementor.pm Lib/IMPL/Code/DirectPropertyImplementor.pm |
diffstat | 4 files changed, 198 insertions(+), 10 deletions(-) [+] |
line wrap: on
line diff
--- 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;
--- 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) = @_;
--- /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
--- /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