Mercurial > pub > Impl
diff Lib/IMPL/Class/Property/Direct.pm @ 49:16ada169ca75
migrating to the Eclipse IDE
author | wizard@linux-odin.local |
---|---|
date | Fri, 26 Feb 2010 10:49:21 +0300 |
parents | 03e58a454b20 |
children | 15d720913562 |
line wrap: on
line diff
--- a/Lib/IMPL/Class/Property/Direct.pm Fri Feb 26 01:43:42 2010 +0300 +++ b/Lib/IMPL/Class/Property/Direct.pm Fri Feb 26 10:49:21 2010 +0300 @@ -1,111 +1,111 @@ -package IMPL::Class::Property::Direct; -use strict; - -use base qw(IMPL::Object::Accessor Exporter); -our @EXPORT = qw(_direct); - -use IMPL::Class::Property; -require IMPL::Exception; - -__PACKAGE__->mk_accessors qw(ExportField); - -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( @{ ($this->{$field} = ( (@_ == 1 and ref $_[0] eq \'ARRAY\') ? $_[0] : [@_] ) || [] ) } );'; -my $list_accessor_get = 'return( @{ $this->{$field} || [] } );'; -my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; -my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; - -my %accessor_cache; -sub mk_acessor { - my ($virtual,$access,$class,$name,$mutators,$field) = @_; - - 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')); - 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 .= "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE; - $code .= "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED; - 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 - } - } -} -END - $factory = eval $code or die new IMPL::Exception('Failed to generate the accessor',$@); - $accessor_cache{$key} = $factory; - } - return $factory->($class,$name,$set,$get, $field); -} - -sub Make { - my ($self,$propInfo) = @_; - - my $isExportField = ref $self ? ($self->ExportField || 0) : 0; - my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); - (my $field = "${class}_$name") =~ s/::/_/g; - - my $propGlob = $class.'::'.$name; - - no strict 'refs'; - *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field); - *$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); - } -} - -sub FieldName { - my ($self,$propInfo) = @_; - - my ($class,$name) = $propInfo->get qw(Class Name); - (my $field = "${class}_$name") =~ s/::/_/g; - return $field; -} - -1; \ No newline at end of file +package IMPL::Class::Property::Direct; +use strict; + +use base qw(IMPL::Object::Accessor Exporter); +our @EXPORT = qw(_direct); + +use IMPL::Class::Property; +require IMPL::Exception; + +__PACKAGE__->mk_accessors qw(ExportField); + +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( @{ ($this->{$field} = ( (@_ == 1 and ref $_[0] eq \'ARRAY\') ? $_[0] : [@_] ) || [] ) } );'; +my $list_accessor_get = 'return( @{ $this->{$field} || [] } );'; +my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; +my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; + +my %accessor_cache; +sub mk_acessor { + my ($virtual,$access,$class,$name,$mutators,$field) = @_; + + 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')); + 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 .= "$access_private\n" if $access == IMPL::Class::Member::MOD_PRIVATE; + $code .= "$access_protected\n" if $access == IMPL::Class::Member::MOD_PROTECTED; + 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 + } + } +} +END + $factory = eval $code or die new IMPL::Exception('Failed to generate the accessor',$@); + $accessor_cache{$key} = $factory; + } + return $factory->($class,$name,$set,$get, $field); +} + +sub Make { + my ($self,$propInfo) = @_; + + my $isExportField = ref $self ? ($self->ExportField || 0) : 0; + my ($class,$name,$virt,$access,$mutators) = $propInfo->get qw(Class Name Virtual Access Mutators); + (my $field = "${class}_$name") =~ s/::/_/g; + + my $propGlob = $class.'::'.$name; + + no strict 'refs'; + *$propGlob = mk_acessor($virt,$access,$class,$name,$mutators,$field); + *$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); + } +} + +sub FieldName { + my ($self,$propInfo) = @_; + + my ($class,$name) = $propInfo->get qw(Class Name); + (my $field = "${class}_$name") =~ s/::/_/g; + return $field; +} + +1;