Mercurial > pub > Impl
diff Lib/IMPL/Class/Property/Direct.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 | 609b59c9f03c |
children | b0c068da93ac |
line wrap: on
line diff
--- a/Lib/IMPL/Class/Property/Direct.pm Fri Mar 05 20:14:45 2010 +0300 +++ b/Lib/IMPL/Class/Property/Direct.pm Tue Mar 09 02:50:45 2010 +0300 @@ -1,7 +1,7 @@ package IMPL::Class::Property::Direct; use strict; -use base qw(IMPL::Object::Accessor Exporter); +use base qw(IMPL::Object::Accessor IMPL::Class::Property::Base Exporter); our @EXPORT = qw(_direct); require IMPL::Object::List; @@ -10,123 +10,67 @@ __PACKAGE__->mk_accessors qw(ExportField); +push @IMPL::Class::Property::Base::factoryParams, qw($field); + sub _direct($) { my ($prop_info) = @_; $prop_info->Implementor( IMPL::Class::Property::Direct->new({ExportField => 1}) ); return $prop_info; } -my $access_private = "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"; -my $access_protected = "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless caller eq \$class;"; -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 $accessor_set = 'return( $this->{$field} = @_ == 1 ? $_[0] : [@_] );'; -my $accessor_get = 'return( $this->{$field} );'; -my $list_accessor_set = '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] : [@_] - )) -);'; -my $list_accessor_get = 'return( - wantarray ? - @{ $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - } : - ( $this->{$field} ? - $this->{$field} : - ( $this->{$field} = IMPL::Object::List->new() ) - ) -);'; -my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; -my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; +sub GenerateGet { + 'return ($this->{$field});'; +} + +sub GenerateSet { + 'return ($this->{$field} = $_[0])'; +} -my %accessor_cache; -sub mk_acessor { - my ($virtual,$access,$class,$name,$mutators,$field,$validator) = @_; - - my ($get,$set) = ref $mutators ? ( $mutators->{get}, $mutators->{set}) : ($mutators & prop_get, $mutators & prop_set); - my $key = join '',$virtual,$access,$get ? 1 : 0,$set ? 1 : 0, (ref $mutators ? 'c' : ($mutators & prop_list() ? 'l' : 's')), $validator ? 1 : 0 ; - my $factory = $accessor_cache{$key}; - if (not $factory) { - my $code = -<<BEGIN; -sub { - my (\$class,\$name,\$set,\$get,\$field) = \@_; - my \$accessor; - \$accessor = sub { - my \$this = shift; -BEGIN - $code .= <<VCALL if $virtual; - my \$method = \$this->can(\$name); - return \$this->\$method(\@_) unless \$method == \$accessor or caller->isa(\$class); -VCALL - $code .= ' 'x8 . "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE; - $code .= ' 'x8 . "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED; - $code .= ' 'x8 . '$this->$validator(@_);'."\n" if $validator; - - my ($codeGet,$codeSet); - if (ref $mutators) { - $codeGet = $get ? $custom_accessor_get : $accessor_get_no; - $codeSet = $set ? $custom_accessor_set : $accessor_set_no; - } else { - if ($mutators & prop_list) { - $codeGet = $get ? $list_accessor_get : $accessor_get_no; - $codeSet = $set ? $list_accessor_set : $accessor_set_no; - } else { - $codeGet = $get ? $accessor_get : $accessor_get_no; - $codeSet = $set ? $accessor_set : $accessor_set_no; - } - } - $code .= -<<END; - if (\@_) { - $codeSet - } else { - $codeGet - } - } +sub GenerateSetList { + '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] : [@_] + )) + );'; } -END - warn $code; - $factory = eval $code; - if (not $factory) { - my $err = $@; - die new IMPL::Exception('Failed to generate the accessor factory',$err); - } - $accessor_cache{$key} = $factory; - } - - 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 $factory->($class,$name,$set,$get, $field, $validator); + +sub GenerateGetList { + 'return( + wantarray ? + @{ $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + } : + ( $this->{$field} ? + $this->{$field} : + ( $this->{$field} = IMPL::Object::List->new() ) + ) + );'; +} + +sub RemapFactoryParams { + my ($self,$propInfo) = @_; + + return $self->SUPER::RemapFactoryParams($propInfo),$self->FieldName($propInfo); } sub Make { - my ($self,$propInfo) = @_; - - my $isExportField = ref $self ? ($self->ExportField || 0) : 0; - my ($class,$name,$virt,$access,$mutators,$attr) = $propInfo->get qw(Class Name Virtual Access Mutators Attributes); - (my $field = "${class}_$name") =~ s/::/_/g; - - my $propGlob = $class.'::'.$name; - - no strict 'refs'; - *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field,$attr->{validator}); - *$propGlob = \$field if $isExportField; - - if (ref $mutators) { - $propInfo->canGet( $mutators->{get} ? 1 : 0); - $propInfo->canSet( $mutators->{set} ? 1 : 0); - } else { - $propInfo->canGet( ($mutators & prop_get) ? 1 : 0); - $propInfo->canSet( ($mutators & prop_set) ? 1 : 0); - } + my ($self,$propInfo) = @_; + + $self->SUPER::Make($propInfo); + + { + no strict 'refs'; + if (ref $self and $self->ExportField) { + my $field = $self->FieldName($propInfo); + *{$propInfo->Class.'::'.$propInfo->Name} = \$field; + } + } } sub FieldName {