Mercurial > pub > Impl
diff lib/IMPL/Code/DirectPropertyImplementor.pm @ 407:c6e90e02dd17 ref20150831
renamed Lib->lib
author | cin |
---|---|
date | Fri, 04 Sep 2015 19:40:23 +0300 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lib/IMPL/Code/DirectPropertyImplementor.pm Fri Sep 04 19:40:23 2015 +0300 @@ -0,0 +1,96 @@ +package IMPL::Code::DirectPropertyImplementor; +use strict; + +require IMPL::Object::List; + +use IMPL::lang qw(:hash); +use IMPL::require { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException', + DirectPropertyInfo => 'IMPL::Class::DirectPropertyInfo' +}; + +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 $get $set $validator $field) }; + +my %cache; + +sub Implement { + my $self = shift; + + my $spec = {}; + + map hashApply($spec,$self->NormalizeSpecification($_)), @_; + + 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"); + + my $id = $self->CreateFactoryId($spec); + my $factory = $cache{$id}; + unless($factory) { + $factory = $self->CreateFactory($spec); + $cache{$id} = $factory; + } + + my $field = join( '_', split(/::/, $class), $name); + + my $accessor = $factory->($class, $name, $spec->{get}, $spec->{set}, $spec->{validator}, $field); + + my $args = { + getter => $spec->{get} ? $accessor : undef, + setter => $spec->{set} ? $accessor : undef, + ownetSet => $spec->{ownerSet} ? 1 : 0, + isList => $spec->{isList} ? 1 : 0, + name => $spec->{name}, + class => $spec->{class}, + type => $spec->{type}, + access => $spec->{access}, + fieldName => $field, + directAccess => $spec->{direct} + }; + + delete @$spec{qw(get set ownerSet isList name class type access field direct)}; + + $args->{attributes} = $spec; + + my $propInfo = DirectPropertyInfo->new($args); + + { + no strict 'refs'; + *{"${class}::$name"} = $accessor; + *{"${class}::$name"} = \$field if $args->{directAccess}; + } + $class->SetMeta($propInfo); + + return $propInfo; +} + +1; \ No newline at end of file