--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Class/Property/Direct.pm	Tue Jul 14 12:54:37 2009 +0400
@@ -0,0 +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