pub/Impl: Lib/Schema.pm comparison

comparison Lib/Schema.pm @ 0:03e58a454b20

РЎРѕР·РґР°РЅ СЂРµРїРѕР·РёС‚Р°СЂРёР№

author	Sergey
date	Tue, 14 Jul 2009 12:54:37 +0400
parents
children	16ada169ca75

comparison

equal deleted inserted replaced

--1:000000000000
+:03e58a454b20
+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;

Mercurial > pub > Impl

comparison Lib/Schema.pm @ 0:03e58a454b20