view Lib/Schema.pm @ 31:d59526f6310e

Small fixes to Test framework (correct handlinf of the compilation errors in the test units) Imported and refactored SQL DB schema from the old project
author Sergey
date Mon, 09 Nov 2009 01:39:16 +0300
parents 03e58a454b20
children 16ada169ca75
line wrap: on
line source

package Schema;
package Schema::TypeName;
package Schema::Type;
package Schema::Template;
package Schema::TemplateSpec;
package Schema::Member;
package Schema::Property;

package Schema::TypeName;
use Common;

#our @ISA = qw(Object);

# можно оптимизировать производительность, создавая объект скалаяр для простых
# имен и обхект хеш для специализаций
# сделано

sub new {
    my $class = shift;
    my $this;
    
    my $name = shift;
    my @list = map { ref $_ eq 'Schema::TypeName' ? $_ : new Schema::TypeName($_) } @_;
    
    die new Exception('TypeName soud be a simple identifier',$name) if not $name =~ /^\w+$/;
    
    if (@list) {
        $this = bless {}, $class;
        $this->{Name} = $name;
        $this->{TemplateList} = \@list if @list;
    } else {
        $this = bless \$name, $class;
    }
    
    return $this;
}

sub Name {
    my $this = shift;
    return (UNIVERSAL::isa($this,'HASH') ? $this->{Name} : $$this);
}

sub Simple {
    return $_[0]->Name;
}

# список параметров типа
sub TemplateList {
    my $this = shift;
    return (UNIVERSAL::isa($this,'HASH') ? (wantarray ? @{$this->{TemplateList}} : $this->{TemplateList} ) : (wantarray ? return () : undef));
}

# имя типа является именем шаблона
sub isTemplateSpec {
    my $this = shift;
    return( UNIVERSAL::isa($this,'HASH') ? 1 : 0 );
}

sub CanonicalName {
    my $this = shift;
    
    if (UNIVERSAL::isa($this,'HASH')) {
        if (my $result = $this->{SavedCanonicalName}) {
            $result;
        } else {
            $result = $this->{Name};
            $result .= '@'. join('#',map {ref $_ eq __PACKAGE__ ? $_->CanonicalName : $_} @{$this->{TemplateList}}) . '@@';
            $this->{SavedCanonicalName} = $result;
        }
    } else {
        $$this;
    }
}

sub Canonical {
    return $_[0]->CanonicalName;
}

# Не регистрирует вновь созданных типов в таблице
# Это из-за случая, когда:
# MyClass { Hash<int> my_map; }, тоесть полученный тип Hahs<int> уже специализирован и он будет сразу инстантинорован
# DoNotCreate для специализации шаблона только существующими типами
sub Resolve {
    my ($this,$TypeTable,$DoNotCreate) = @_;
    
    if (my $type = $TypeTable->ResolveType($this,$DoNotCreate)) {
        # предполагается, что схема автоматически создает ссылки вперед на неопределенные простые типы
        return $type;
    } else {
        if ($this->isTemplateSpec) {
            return new Schema::TemplateSpec($this->Name,map {ref $_ eq __PACKAGE__ ? $_->Resolve($TypeTable,$DoNotCreate) : Schema::TypeName->new($_)->Resolve($TypeTable,$DoNotCreate)} @{$this->{TemplateList}} );
        } else {
            die new Exception("Simple type not found", $this->Name);
        }
    }
}

package Schema::TypeTable;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty(Table => ACCESS_NONE);
    DeclareProperty(NextTable => ACCESS_NONE);
}

sub CTOR {
    my ($this,$nextTable) = @_;
    $this->{$NextTable} = $nextTable;
}

sub ResolveType {
    my ($this,$TypeName,@args) = @_;
    
    if (my $Type = $this->{$Table}->{$TypeName->CanonicalName}) {
        return $Type;
    } elsif($this->{$NextTable}) {
        return $this->{$NextTable}->ResolveType($TypeName,@args);
    } else {
        return undef;
    }
}

sub RegisterType {
    my ($this,$Type) = @_;
    
    if (not $this->{$Table}->{$Type->Name->CanonicalName}) {
        $this->{$Table}->{$Type->Name->CanonicalName} = $Type;
    } else {
        die new Exception("A type already registered",$Type->Name->CanonicalName);
    }
}

sub _ListTypes {
    my $this = shift;
    return values %{$this->{$Table}};
}

sub Dispose {
    my $this = shift;
    
    $_->Dispose foreach values %{$this->{$Table} ? $this->{$Table} : {} };
    
    delete $this->{$Table};
    
    $this->SUPER::Dispose;
}

# Специализация шаблона - это имя специализируемого шаблона и параметры, которые будут ему переданы (важен порядок параметров)
# Специализация шаблона параметрами пораждает частично специализированный шаблон, который по сути также является шаблоном
# Если специализация полная, то можно создать экземпляр шаблона, тоесть полноценный тип
package Schema::TemplateSpec;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty(Name => ACCESS_READ);
    DeclareProperty(Parameters => ACCESS_READ);
    DeclareProperty(TemplateList => ACCESS_READ);
}

sub CTOR {
    my ($this,$templateName,@typeList) = @_;

    my %Params;

    $this->{$TemplateList} = \@typeList;

    # вычисляем параметры данной специализации
    my @nameList;
    foreach $typeItem (@typeList) {
        map { $Params{$_->Name} = $_ } @{$typeItem->Parameters} if $typeItem->isTemplate;
        push @nameList, $typeItem->Name;
    }

    $this->{$Parameters} = [ values %Params ];
    $this->{$Name} = new Schema::TypeName($templateName,@nameList);
}

sub isTemplate {
    1;
}

sub canInstantinate {
    my ($this) = @_;
    if (@{$this->{$Parameters}}) {
        0;
    } else {
        1;
    }
}

sub Specialize {
    my ($this,$refParams,$TypeTable) = @_;
    
    my @specializedList = map {$_->isTemplate && !$_->canInstantinate ? $_->Specialize($refParams,$TypeTable) : $_ } @{$this->{$TemplateList}};

    if ($TypeTable) {
        
        my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList);
        my $templateSpec = $TypeTable->ResolveType($TypeName);
        if (not $templateSpec) {
            $templateSpec = new Schema::TemplateSpec($this->Name->Name,@specializedList);
            $TypeTable->RegisterType($templateSpec);
        }
        return $templateSpec;
    } else {
        return new Schema::TemplateSpec($this->Name->Name,@specializedList);
    }
}

# Параметр шаблона
# По сути является шаблоном типа Param_Name<T> -> T;
package Schema::Parameter;

sub new {
    my $TypeName = new Schema::TypeName($_[1]);
    bless \$TypeName,$_[0];
}

sub Name {
    ${shift()};
}

sub Specialize {
    my ($this,$refArgs) = @_;
    return $refArgs->{$$this->Name};
}

sub isTemplate {
    1;
}

sub canInstantinate {
    0;
}

sub Parameters {
    if (wantarray) {
        shift;
    } else {
        [shift];
    }
}


# Член класса
package Schema::Member;
use Common;
our @ISA = qw(Object);
our $Abstract = 1;

BEGIN {
    DeclareProperty(Name => ACCESS_READ);
}
sub CTOR {
    my($this,$name) =  @_;
    
    $this->{$Name} = $name;
}

# Член класса - свойство.
# Свойство может быть шаблоном, если шаблоном является его тип
package Schema::Property;
use Common;
our @ISA = qw(Schema::Member);

BEGIN {
    DeclareProperty(Type => ACCESS_READ);
}

sub CTOR {
    my ($this,$name,$type) = @_;
    $this->SUPER::CTOR($name);
    
    $this->{$Type} = $type or die new Exception("A type for the property must be specified",$name);
}

sub isTemplate {
    my $this = shift;
    return $this->{$Type}->isTemplate;
}

sub canInstantinate {
    my $this = shift;
    return $this->{$Type}->canInstantinate;
}

sub Instantinate {
    my ($this,$Schema) = @_;
    return new Schema::Property($this->Name,$Schema->Instantinate($this->{$Type}));
}

sub Specialize {
    my ($this,$refParams,$TypeTable) = @_;
    return new Schema::Property($this->Name,$this->{$Type}->Specialize($refParams,$TypeTable));
}

# Тип, описывает тип объекта
package Schema::Type;
use Common;
our @ISA = qw(Object);

BEGIN {
    DeclareProperty(Name => ACCESS_READ);
    DeclareProperty(Schema => ACCESS_READ);
    DeclareProperty(Members => ACCESS_READ);
    DeclareProperty(BaseList => ACCESS_READ);
    DeclareProperty(Attributes => ACCESS_READ); #hash of attributes
}

sub CTOR {
    my ($this,$argSchema,$name) = @_;
    
    $this->{$Name} = ref $name eq 'Schema::TypeName' ? $name : new Schema::TypeName($name);
    $this->{$Schema} = $argSchema;
}

sub isTemplate {
    0;
}

sub Equals {
    my ($this,$other) = @_;
    if (UNIVERSAL::isa($other,'Schema::Type')) {
        return ($this->Name->CanonicalName eq $other->Name->CanonicalName);
    } else {
        return 1;
    }
}

sub CreateProperty {
    my ($this,$PropName,$TypeName) = @_;

    $PropType = $this->_ResolveType($TypeName);

    return new Schema::Property($PropName,$PropType);
}

sub AddBase {
    my ($this,$type) = @_;
    
    $type = $this->_ResolveType($type);
    
    not $type->isType($this) or die new Exception('Cant derive from the class which is derived from self', $this->Name->CanonicalName, $type->Name->CanonicalName);
    
    push @{$this->{$BaseList}},$type;
}

sub isType {
    my ($this,$type,$maxlevel) = @_;
    
    return 0 if defined $maxlevel and $maxlevel < 0;
    my $typeName = UNIVERSAL::isa($type,'Schema::Type') ? $type->Name : $type ;
    
    return (
        $this->{$Name}->CanonicalName eq $typeName->CanonicalName ?
            1
        :
            scalar (grep {$_->isType($typeName,defined $maxlevel ? $maxlevel - 1 : undef)} $this->BaseList)
    );
}

sub ValidateType {
    my ($this,$type) = @_;
    
    die new Exception('Can\'t use an unspecialized template',$type->Name->CanonicalName) if ($type->isa('Schema::TypeTemplate'));
        
    if ($type->isTemplate and not $type->canInstantinate) {
        die new Exception('Cant use a not fully specialized template in a simple type',$type->Name->CanonicalName, $this->Name->Name) if not $this->isTemplate;
        
        my %Params = map {$_->Name->Name() , 1} @{$this->Parameters};
        my @Unresolved = grep {not $Params{$_->Name->Name}} @{$type->Parameters()};
        
        die new Exception('Not all parameters can be rsolved',map {$_->Name->Name} @Unresolved) if @Unresolved;
    }
}

sub InsertProperty {
    my ($this,$PropName,$PropType) = @_;
    
    $PropType = $this->_ResolveType($PropType);

    my $prop = new Schema::Property($PropName,$PropType);
    
    push @{$this->{$Members}}, $prop;

    return $prop;
}

sub AddMember {
    my ($this,$member) = @_;
    
    push @{$this->{$Members}},$member;
}

sub GetTypeTable {
    my $this = shift;
    return $this->{$Schema};
}

sub _ResolveType {
    my ($this,$type) = @_;
    if ($type->isa('Schema::TypeName')) {
        $type = $type->Resolve($this->GetTypeTable());
    } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) {
        $this->ValidateType($type);
    } else {
        die new Exception('Invalid type',$type);
    }
    
    $type = $this->{$Schema}->Instantinate($type) if ($type->isTemplate and $type->canInstantinate and not $this->isTemplate);
    return $type;
}

sub ListMembers {
    my ($this,%options) = @_;
    
    my @members;
    
    if ($options{'foreign'}) {
        push @members, $_->isa('Schema::Type') ? $_->ListMembers(%options) : () foreach @{$this->{$BaseList} ? $this->{$BaseList} : []};
    }
    push @members, @{$this->{$Members} ? $this->{$Members} : []};
    
    return @members;
}

sub FindMembers {
    my ($this,$memberName,%options) = @_;
    
    my @members = grep { $_->Name eq $memberName} @{$this->{$Members} ? $this->{$Members} : []};
    
    if ($options{'deep'}) {
        push @members,$_->ListMembers(%options) foreach @{$this->{$BaseList} ? $this->{$BaseList} : []};
    }
    
    if(wantarray) {
        return @members;
    } else {
        return shift @members;
    }
}

sub SetAttributes {
    my ($this,%attributes) = @_;
    
    while (my ($key,$value) = each %attributes) {
        $this->{$Attributes}{$key} = $value;
    }
}

sub GetAttribute {
    my ($this,$name) = @_;
    
    return $this->{$Attributes}{$name};
}

sub _dump {
    my ($this) = @_;
    return $this->Name->CanonicalName;
}

sub Dispose {
    my ($this) = @_;
    
    undef %{$this};
    $this->SUPER::Dispose;
}

# Шаблон - праметризованный тип
package Schema::Template;
use Common;
our @ISA = qw(Schema::Type);

BEGIN {
    DeclareProperty(Parameters => ACCESS_READ);
    DeclareProperty(LocalTypes => ACCESS_NONE);

}

sub CTOR {
    my ($this,$Schema,$name,@args) = @_;
    # параметры не являются чачтью имени
    $this->SUPER::CTOR($Schema,$name);
    
    $this->{$Parameters} = [ map {new Schema::Parameter($_) } @args ];
    my $TypeTable = new Schema::TypeTable($Schema);
    $TypeTable->RegisterType($_) foreach @{$this->{$Parameters} };
    $this->{$LocalTypes} = $TypeTable;
}

sub GetTypeTable {
    my ($this) = @_;
    return $this->{$LocalTypes};
}

sub isTemplate {
    1;
}

sub Specialize {
    my ($this,$refArgs,$TypeTable) = @_;
    
    my @specializedList = map {$_->Specialize($refArgs)} @{$this->{$Parameters}};
    
    # создаем специализацию шаблона
    my $specializedType;
    
    if ($TypeTable) {
        my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList);
        
        if(my $specializedType = $TypeTable->ResolveType($TypeName)) {
            return $specializedType;
        } else {
            $specializedType = new Schema::TemplateSpec($this->Name->Name, @specializedList );
            $TypeTable->RegisterType($specializedType);
            return $specializedType;
        }
    } else {
        return new Schema::TemplateSpec($this->Name->Name, @specializedList );
    }
}

sub canInstantinate {
    0;
}

# создание экземпляра шаблона.
# Создать шаблон = полностью его специализировать
# Принимает набор параметров шаблона и создает новый тип или возвращает из схемы
sub Instantinate {
    my ($this,$refArgs,$instance) = @_;

    my %ParamInstances;
    my @TemplateListNames;
    
    foreach my $param (@{$this->{$Parameters}}) {
        my $type = $refArgs->{$param->Name->Name};
        die new Exception("Parameter not specified",$param->Name->Name) if not $type;
        if ($type->isTemplate) {
            if ($type->canInstantinate) {
                $type = $this->Schema->Instantinate($type);
            } else {
                die new Exception("Parameter must be a fully speciazlied type",$param->Name->Name);
            }
        }
        
        $ParamInstances{$param->Name->Name} = $type;
        push @TemplateListNames, $type->Name;
    }
    
    # параметры представляют собой реальные типы, переходим к созданию типа
    # данная функция беусловно создает новый тип, эту функцию использует схем
    
    $instance = $this->Schema->CreateType( new Schema::TypeName($this->Name->Name,@TemplateListNames) ) if not $instance;

    $instance->SetAttributes(%{$this->Attributes}) if $this->Attributes;
    $instance->SetAttributes(
        TemplateInstance => {
            Template => $this,
            Parameters => \%ParamInstances
        }
    );
    
    foreach my $Ancestor ($this->BaseList) {
        $instance->AddBase(
            $Ancestor->isTemplate ?
                ( $Ancestor->canInstantinate ?
                    $this->Schema->Instantinate($Ancestor)
                    :
                    $this->Schema->Instantinate($Ancestor->Specialize(\%ParamInstances,$this->GetTypeTable))
                )
                :
                $Ancestor
        );
    }
    
    foreach my $Member ($this->Members) {
        $instance->AddMember(
            $Member->isTemplate ?
                ($Member->canInstantinate ?
                    $Member->Instantinate($this->Schema)
                    :
                    $Member->Specialize(\%ParamInstances,$this->GetTypeTable)->Instantinate($this->Schema)
                )
                :
                $Member
        );
    }

    return $instance;
}

sub _ResolveType {
    my ($this,$type) = @_;
    if ($type->isa('Schema::TypeName')) {
        $type = $type->Resolve($this->GetTypeTable());
        if (not $this->{$LocalTypes}->ResolveType($type->Name)) {
            $this->{$LocalTypes}->RegisterType($type);
        }
    } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) {
        $this->ValidateType($type);
    } else {
        die new Exception('Invalid type',$type);
    }

    return $type;
}


package Schema;
use strict;
use Common;
our @ISA = qw(Schema::TypeTable);

BEGIN {
    DeclareProperty(PendingInstances => ACCESS_NONE);
    DeclareProperty(UnresolvedTypes => ACCESS_NONE);
}

sub CTOR {
    
}

# Схема автоматически создает ссылки вперед на несуществующие простые типы
sub ResolveType {
    my ($this,$TypeName,$DoNotCreate) = @_;
    
    if (my $type = $this->SUPER::ResolveType($TypeName)) {
        return $type;
    } else {
        if (not $TypeName->isTemplateSpec and not $DoNotCreate) {
            $type = new Schema::Type($this,$TypeName);
            $this->RegisterType($type);
            $this->{$UnresolvedTypes}->{$TypeName->CanonicalName} = $TypeName;
            return $type;
        } else {
            return undef;
        }
    }
}

sub CreateType {
    my ($this,$TypeName) = @_;
    
    $TypeName = new Schema::TypeName($TypeName) if ref $TypeName ne 'Schema::TypeName';
    
    if (my $type = $this->SUPER::ResolveType($TypeName)) {
        if ($this->{$UnresolvedTypes}->{$TypeName->CanonicalName}) {
            delete $this->{$UnresolvedTypes}->{$TypeName->CanonicalName};
            return $type;
        } else {
            die new Exception("Type already exists",$TypeName->CanonicalName);
        }
    } else {
        $type = new Schema::Type($this,$TypeName);
        $this->SUPER::RegisterType($type);
        return $type;
    }
}

sub CreateTemplate {
    my ($this,$TemplateName,@ParamNames) = @_;
    
    die new Exception("Parameters required for the template") if not @ParamNames;
    
    if (ref $TemplateName eq 'Schema::TypeName') {
        die new Exception('Template specialization is not valid name for a new template',$TemplateName->CanonicalName) if $TemplateName->isTemplateSpec;
    } else {
        $TemplateName = new Schema::TypeName($TemplateName);
    }
    
    if (my $type = $this->SUPER::ResolveType($TemplateName)) {
        die new Exception('Type already exists');
    } else {
        $type = new Schema::Template($this,$TemplateName,@ParamNames);
        $this->SUPER::RegisterType($type);
        return $type;
    }
}

# создание экземпляра шаблона
# создается новый пустой тип, добавляется в PendingInstances
sub Instantinate {
    my ($this,$TemplateSpec) = @_;
    
    # при специализации напрмер этого: T m_var; получим для инстантиниции real_type m_var; и не проверяя отдадим его на специализацию,
    # вот и обработка
    return $TemplateSpec if not $TemplateSpec->isTemplate;
    
    die new Exception('Only a template specialization can be instantinated') if ref $TemplateSpec ne 'Schema::TemplateSpec';
    die new Exception('Only fully specialized template can be instantinated') if not $TemplateSpec->canInstantinate;
    
    my $TypeName = $TemplateSpec->Name;
    
    if (my $type = $this->SUPER::ResolveType($TypeName)) {
        return $type;
    } else {
        $type = new Schema::Type($this,$TypeName);
        $this->SUPER::RegisterType($type);
        push @{$this->{$PendingInstances}},[$TemplateSpec,$type];
        return $type;
    }
}

sub Close {
    my ($this) = @_;
    
    if (keys %{$this->{$UnresolvedTypes}}) {
        die new Exception('Some type definitions are absent',keys %{$this->{$UnresolvedTypes}});
    }
    
    if ($this->{$PendingInstances}) {
        while( my $ref = shift @{$this->{$PendingInstances}} ) {
            my ($spec,$instance) = @$ref;
            if (my $typeTemplate = $this->SUPER::ResolveType( new Schema::TypeName($spec->Name->Name) )) {
                die new Exception('Can\'t instantinate a specialization of the simple type',$instance->Name->CanonicalName) if not $typeTemplate->isTemplate;
                if (scalar(@{$typeTemplate->Parameters}) == scalar(@{$spec->TemplateList})) {
                    my @Params = @{$typeTemplate->Parameters};
                    $typeTemplate->Instantinate({map { (shift @Params)->Name->Name, $_ } @{$spec->TemplateList}},$instance);
                } else {
                    die new Exception('A template parameters doesn\'t match to the specialization list',$instance->Name->CanonicalName);
                }
            } else {
                die new Exception('Can\'t instantinate a specialization, the specified template isn\'t found', $instance->Name->CanonicalName);
            }
        }
        
        delete $this->{$PendingInstances};
    }
}

sub EnumTypes {
    my ($this,%options) = @_;
    
    return grep { ($_->isTemplate and not $options{'skip_templates'}) or (not $_->isTemplate and not $options{'skip_classes'}) } $this->_ListTypes;
}

sub Dispose {
    my ($this) = @_;
    
    delete $this->{$UnresolvedTypes};
    
    $this->SUPER::Dispose;
}

1;