Mercurial > pub > Impl
changeset 276:8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
author | sergey |
---|---|
date | Thu, 31 Jan 2013 17:37:44 +0400 |
parents | 6253872024a4 |
children | 6585464c4664 |
files | Lib/IMPL/Class/DirectPropertyInfo.pm Lib/IMPL/Class/Member.pm Lib/IMPL/Class/Property.pm Lib/IMPL/Class/Property/Base.pm Lib/IMPL/Object.pm Lib/IMPL/Object/Abstract.pm |
diffstat | 6 files changed, 76 insertions(+), 28 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/Class/DirectPropertyInfo.pm Thu Jan 31 17:37:44 2013 +0400 @@ -0,0 +1,15 @@ +package IMPL::Class::DirectPropertyInfo; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::Class::PropertyInfo' => '@_' + ], + props => [ + fieldName => PROP_RW, + directAccess => PROP_RW + ] +}; + +1; \ No newline at end of file
--- a/Lib/IMPL/Class/Member.pm Thu Jan 31 02:18:31 2013 +0400 +++ b/Lib/IMPL/Class/Member.pm Thu Jan 31 17:37:44 2013 +0400 @@ -3,31 +3,30 @@ use parent qw(Exporter); our @EXPORT = qw(virtual public private protected); + +use IMPL::Const qw(:access); + use IMPL::Class::Meta; require IMPL::Class::MemberInfo; -#TODO: remove -use constant { - MOD_PUBLIC => 1, - MOD_PROTECTED => 2, - MOD_PRIVATE => 3 -}; - sub public($) { - $_[0]->access(MOD_PUBLIC); - $_[0]->Implement; - $_[0]; + my $info = shift; + $info->{access} = ACCESS_PUBLIC; + my ($class,$implementor) = delete $info->{'class','-implementor'}; + $class->$implementor($info); } sub private($) { - $_[0]->access(MOD_PRIVATE); - $_[0]->Implement; - $_[0]; + my $info = shift; + $info->{access} = ACCESS_PRIVATE; + my ($class,$implementor) = delete $info->{'class','-implementor'}; + $class->$implementor($info); } sub protected($) { - $_[0]->access(MOD_PROTECTED); - $_[0]->Implement; - $_[0]; + my $info = shift; + $info->{access} = ACCESS_PROTECTED; + my ($class,$implementor) = delete $info->{'class','-implementor'}; + $class->$implementor($info); } 1;
--- a/Lib/IMPL/Class/Property.pm Thu Jan 31 02:18:31 2013 +0400 +++ b/Lib/IMPL/Class/Property.pm Thu Jan 31 17:37:44 2013 +0400 @@ -1,12 +1,15 @@ package IMPL::Class::Property; use strict; use parent qw(Exporter); + BEGIN { our @EXPORT = qw(property prop_get prop_set owner_set prop_none prop_all prop_list CreateProperty); } -require IMPL::Class::Member; -require IMPL::Class::PropertyInfo; +use IMPL::lang qw(:hash); +use IMPL::Const qw(:prop); +use Carp qw(carp); +require IMPL::Class::Memeber; sub import { __PACKAGE__->export_to_level(1,@_); @@ -20,16 +23,31 @@ sub prop_all { 3 }; sub prop_list { 4 }; -sub property($$;$) { - my ($propName,$mutators,$attributes) = @_; - my $Info = new IMPL::Class::PropertyInfo( {name => $propName, mutators => $mutators, class => scalar(caller), attributes => $attributes } ); - return $Info; +sub property($$) { + my ($propName,$attributes) = @_; + + $attributes = { + get => $attributes & PROP_GET, + set => $attributes & PROP_SET, + isList => $attributes & PROP_LIST + } unless ref $attributes; + + return hashMerge ( + $attributes, + { + -implementor => 'ImplementProperty', + name => $propName, + class => scalar(caller), + } + ); } sub CreateProperty { - my ($class,$propName,$mutators,$attributes) = @_; - my $Info = new IMPL::Class::PropertyInfo( {name => $propName, mutators => $mutators, class => $class, attributes => $attributes} ); - return $Info; + my ($class,$propName,$attributes) = @_; + + carp "Using create property is deprecated, use ImplementProperty instead"; + + $class->ImplementProperty($propName,$attributes); }; 1;
--- a/Lib/IMPL/Class/Property/Base.pm Thu Jan 31 02:18:31 2013 +0400 +++ b/Lib/IMPL/Class/Property/Base.pm Thu Jan 31 17:37:44 2013 +0400 @@ -107,7 +107,11 @@ } sub Implement { - my ($self,$spec) = @_; + my ($self, $name, $spec) = @_; + + { + name => + } } # extract from property info: class, name, get_accessor, set_accessor, validator
--- a/Lib/IMPL/Object.pm Thu Jan 31 02:18:31 2013 +0400 +++ b/Lib/IMPL/Object.pm Thu Jan 31 17:37:44 2013 +0400 @@ -3,13 +3,12 @@ use parent qw(IMPL::Object::Abstract); require IMPL::Class::Property::Direct; +use IMPL::Const qw(:prop); sub surrogate { bless {}, ref $_[0] || $_[0]; } -__PACKAGE__->static_accessor( propertyInfoClass => 'IMPL::Class::DirectPropertyInfo' ); - sub new { my $class = shift; my $self = bless {}, ref($class) || $class; @@ -22,6 +21,18 @@ 'IMPL::Class::Property::Direct' } +sub ImplementProperty { + my ($self,$name,$attributes) = @_; + + $attributes = { + get => $attributes & PROP_GET, + set => $attributes & PROP_SET, + isList => $attributes & PROP_LIST + } unless ref $attributes; + + $self->_ProppertyImplementor->Implement($name,$attributes); +} + 1; __END__