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

use IMPL::Class::Property;

require IMPL::Class::Member;

sub factoryParams { qw($class $name $set $get $validator) };

my %factoryCache;

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 $custom_accessor_get = 'unshift @_, $this and goto &$get;';
my $custom_accessor_set = 'unshift @_, $this and goto &$set;';

my $validator_code = '$this->$validator(@_);'; 

my %access_code = (
    IMPL::Class::Member::MOD_PUBLIC , "",
    IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
    IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" 
);

my $virtual_call = q(
        my $method = $this->can($name);
        return $this->$method(@_) unless $method == $accessor or caller->isa($class);
);

my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;";

sub GenerateAccessors {
    my ($self,$param,@params) = @_;
    
    my %accessors;
    
    if (not ref $param) {
        if ($param & prop_list) {
            $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef;
            $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef;
        } else {
            $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef;
            $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef;
        }
        $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : "";
    } elsif (UNIVERSAL::isa($param,'HASH')) {
        $accessors{get} = $param->{get} ? $custom_accessor_get : undef;
        $accessors{set} = $param->{set} ? $custom_accessor_set : undef;
        $accessors{owner} = "";
    } else {
        die new IMPL::Exception('The unsupported accessor/mutators supplied',$param);
    }
    
    return \%accessors;
}

sub GenerateSet {
    die new IMPL::Exception("Standard accessors not supported",'Set');
}
    
sub GenerateGet {
    die new IMPL::Exception("Standard accessors not supported",'Get');
}

sub GenerateGetList {
    die new IMPL::Exception("Standard accessors not supported",'GetList');
}

sub GenerateSetList {
    my ($self) = @_;
    die new IMPL::Exception("Standard accessors not supported",'SetList');
}

sub Make {
    my ($self,$propInfo) = @_;
    
    my $key = $self->MakeFactoryKey($propInfo);
    
    my $factoryInfo = $factoryCache{$key};
    
    unless ($factoryInfo) {
        my $mutators = $self->GenerateAccessors($propInfo->Mutators);
        $factoryInfo = {
            factory => $self->CreateFactory(
                $access_code{ $propInfo->Access },
                $propInfo->Attributes->{validator} ? $validator_code : "",
                $mutators->{owner},
                $mutators->{get} || $accessor_get_no,
                $mutators->{set} || $accessor_set_no
            ),
            mutators => $mutators
        };
        $factoryCache{$key} = $factoryInfo; 
    }
    
    {
        no strict 'refs';
        *{ $propInfo->Class.'::'.$propInfo->Name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo));
    }
    
    my $mutators = $factoryInfo->{mutators};
    
    $propInfo->canGet( $mutators->{get} ? 1 : 0 );
    $propInfo->canSet( $mutators->{set} ? 1 : 0 );
    $propInfo->ownerSet( $mutators->{owner} );
    
    1;
}

# extract from property info: class, name, get_accessor, set_accessor, validator
sub RemapFactoryParams {
    my ($self,$propInfo) = @_;
    
    my $mutators = $propInfo->Mutators;
    my $class = $propInfo->Class;
    my $validator = $propInfo->Attributes->{validator};
    
    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 (
        $propInfo->get(qw(Class Name)),
        (ref $mutators?
            ($mutators->{set},$mutators->{get})
            :
            (undef,undef)
        ),
        $validator
    );
}

sub MakeFactoryKey {
    my ($self,$propInfo) = @_;
    
    my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator});
    
    my $implementor = ref $self || $self;
    
    return join ('',
        $implementor,
        $access,
        $validator ? 'v' : 'n',
        ref $mutators ?
            ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0)
            :
            ('s',$mutators) 
    ); 
}

sub CreateFactory {
    my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_;
    
    my $strParams = join(',',$self->factoryParams);
    
    my $factory = <<FACTORY;
    
sub {
    my ($strParams) = \@_;
    my \$accessor;
    \$accessor = sub {
        my \$this = shift;
        $codeAccessCheck
        if (\@_) {
            $codeOwnerCheck
            $codeValidator
            $codeSet
        } else {
            $codeGet
        }
    }
}
FACTORY

    return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
}

1;

__END__

=pod

=head1 DESCRIPTION

Базовый класс для реализации свойств.

По существу свойства состоят из двух методов для установки и получения значений. Также
существует несколько вариантов доступа к свойству, и метод верификации значения. Еще
свойства могут быть виртуальными.

Для создания реализатора свойств достаточно унаследовать от этого класса и описать
методы для генерации кода получения и установки значения.

=head1 MEMBERS

=over

=item C<Make($propertyInfo)>

Создает свойство у класса, на основе C<$propertyInfo>, описывающего свойство. C<IMPL::Class::PropertyInfo>.

=back 

=cut