Mercurial > pub > Impl
view Lib/IMPL/Class/Property/Direct.pm @ 20:267460284fb3
DOM Schema
author | Sergey |
---|---|
date | Tue, 22 Sep 2009 17:17:38 +0400 |
parents | 03e58a454b20 |
children | 16ada169ca75 |
line wrap: on
line source
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;