package IMPL::Class::Property::Direct;
use strict;

use base qw(IMPL::Object::Accessor Exporter);
our @EXPORT = qw(_direct);

require IMPL::Object::List;
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(
	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;';

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
        }
    }
}
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 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);
    }
}

sub FieldName {
    my ($self,$propInfo) = @_;
    
    my ($class,$name) = $propInfo->get qw(Class Name);
    (my $field = "${class}_$name") =~ s/::/_/g;
    return $field;
}

1;