annotate Lib/Schema.pm @ 7:94d47b388442

Улучшены тесты Исправлены ошибки Улучшена документация Работа над схемой DOM
author Sergey
date Mon, 24 Aug 2009 01:05:34 +0400
parents 03e58a454b20
children 16ada169ca75
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
1 package Schema;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
2 package Schema::TypeName;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
3 package Schema::Type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
4 package Schema::Template;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
5 package Schema::TemplateSpec;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
6 package Schema::Member;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
7 package Schema::Property;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
8
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
9 package Schema::TypeName;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
10 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
11
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
12 #our @ISA = qw(Object);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
13
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
14 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
15 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
16 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
17
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
18 sub new {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
19 my $class = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
20 my $this;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
21
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
22 my $name = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
23 my @list = map { ref $_ eq 'Schema::TypeName' ? $_ : new Schema::TypeName($_) } @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
24
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
25 die new Exception('TypeName soud be a simple identifier',$name) if not $name =~ /^\w+$/;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
26
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
27 if (@list) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
28 $this = bless {}, $class;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
29 $this->{Name} = $name;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
30 $this->{TemplateList} = \@list if @list;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
31 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
32 $this = bless \$name, $class;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
33 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
34
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
35 return $this;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
36 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
37
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
38 sub Name {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
39 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
40 return (UNIVERSAL::isa($this,'HASH') ? $this->{Name} : $$this);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
41 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
42
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
43 sub Simple {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
44 return $_[0]->Name;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
45 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
46
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
47 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
48 sub TemplateList {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
49 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
50 return (UNIVERSAL::isa($this,'HASH') ? (wantarray ? @{$this->{TemplateList}} : $this->{TemplateList} ) : (wantarray ? return () : undef));
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
51 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
52
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
53 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
54 sub isTemplateSpec {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
55 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
56 return( UNIVERSAL::isa($this,'HASH') ? 1 : 0 );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
57 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
58
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
59 sub CanonicalName {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
60 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
61
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
62 if (UNIVERSAL::isa($this,'HASH')) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
63 if (my $result = $this->{SavedCanonicalName}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
64 $result;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
65 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
66 $result = $this->{Name};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
67 $result .= '@'. join('#',map {ref $_ eq __PACKAGE__ ? $_->CanonicalName : $_} @{$this->{TemplateList}}) . '@@';
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
68 $this->{SavedCanonicalName} = $result;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
69 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
70 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
71 $$this;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
72 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
73 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
74
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
75 sub Canonical {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
76 return $_[0]->CanonicalName;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
77 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
78
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
79 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
80 # - , :
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
81 # MyClass { Hash<int> my_map; }, Hahs<int>
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
82 # DoNotCreate
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
83 sub Resolve {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
84 my ($this,$TypeTable,$DoNotCreate) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
85
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
86 if (my $type = $TypeTable->ResolveType($this,$DoNotCreate)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
87 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
88 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
89 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
90 if ($this->isTemplateSpec) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
91 return new Schema::TemplateSpec($this->Name,map {ref $_ eq __PACKAGE__ ? $_->Resolve($TypeTable,$DoNotCreate) : Schema::TypeName->new($_)->Resolve($TypeTable,$DoNotCreate)} @{$this->{TemplateList}} );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
92 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
93 die new Exception("Simple type not found", $this->Name);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
94 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
95 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
96 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
97
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
98 package Schema::TypeTable;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
99 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
100 our @ISA = qw(Object);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
101
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
102 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
103 DeclareProperty(Table => ACCESS_NONE);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
104 DeclareProperty(NextTable => ACCESS_NONE);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
105 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
106
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
107 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
108 my ($this,$nextTable) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
109 $this->{$NextTable} = $nextTable;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
110 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
111
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
112 sub ResolveType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
113 my ($this,$TypeName,@args) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
114
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
115 if (my $Type = $this->{$Table}->{$TypeName->CanonicalName}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
116 return $Type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
117 } elsif($this->{$NextTable}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
118 return $this->{$NextTable}->ResolveType($TypeName,@args);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
119 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
120 return undef;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
121 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
122 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
123
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
124 sub RegisterType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
125 my ($this,$Type) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
126
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
127 if (not $this->{$Table}->{$Type->Name->CanonicalName}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
128 $this->{$Table}->{$Type->Name->CanonicalName} = $Type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
129 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
130 die new Exception("A type already registered",$Type->Name->CanonicalName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
131 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
132 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
133
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
134 sub _ListTypes {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
135 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
136 return values %{$this->{$Table}};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
137 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
138
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
139 sub Dispose {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
140 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
141
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
142 $_->Dispose foreach values %{$this->{$Table} ? $this->{$Table} : {} };
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
143
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
144 delete $this->{$Table};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
145
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
146 $this->SUPER::Dispose;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
147 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
148
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
149 # - , ( )
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
150 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
151 # , ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
152 package Schema::TemplateSpec;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
153 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
154 our @ISA = qw(Object);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
155
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
156 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
157 DeclareProperty(Name => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
158 DeclareProperty(Parameters => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
159 DeclareProperty(TemplateList => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
160 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
161
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
162 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
163 my ($this,$templateName,@typeList) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
164
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
165 my %Params;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
166
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
167 $this->{$TemplateList} = \@typeList;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
168
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
169 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
170 my @nameList;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
171 foreach $typeItem (@typeList) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
172 map { $Params{$_->Name} = $_ } @{$typeItem->Parameters} if $typeItem->isTemplate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
173 push @nameList, $typeItem->Name;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
174 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
175
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
176 $this->{$Parameters} = [ values %Params ];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
177 $this->{$Name} = new Schema::TypeName($templateName,@nameList);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
178 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
179
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
180 sub isTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
181 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
182 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
183
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
184 sub canInstantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
185 my ($this) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
186 if (@{$this->{$Parameters}}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
187 0;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
188 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
189 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
190 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
191 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
192
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
193 sub Specialize {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
194 my ($this,$refParams,$TypeTable) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
195
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
196 my @specializedList = map {$_->isTemplate && !$_->canInstantinate ? $_->Specialize($refParams,$TypeTable) : $_ } @{$this->{$TemplateList}};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
197
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
198 if ($TypeTable) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
199
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
200 my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
201 my $templateSpec = $TypeTable->ResolveType($TypeName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
202 if (not $templateSpec) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
203 $templateSpec = new Schema::TemplateSpec($this->Name->Name,@specializedList);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
204 $TypeTable->RegisterType($templateSpec);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
205 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
206 return $templateSpec;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
207 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
208 return new Schema::TemplateSpec($this->Name->Name,@specializedList);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
209 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
210 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
211
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
212 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
213 # Param_Name<T> -> T;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
214 package Schema::Parameter;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
215
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
216 sub new {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
217 my $TypeName = new Schema::TypeName($_[1]);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
218 bless \$TypeName,$_[0];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
219 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
220
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
221 sub Name {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
222 ${shift()};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
223 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
224
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
225 sub Specialize {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
226 my ($this,$refArgs) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
227 return $refArgs->{$$this->Name};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
228 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
229
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
230 sub isTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
231 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
232 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
233
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
234 sub canInstantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
235 0;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
236 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
237
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
238 sub Parameters {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
239 if (wantarray) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
240 shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
241 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
242 [shift];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
243 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
244 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
245
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
246
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
247 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
248 package Schema::Member;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
249 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
250 our @ISA = qw(Object);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
251 our $Abstract = 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
252
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
253 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
254 DeclareProperty(Name => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
255 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
256 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
257 my($this,$name) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
258
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
259 $this->{$Name} = $name;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
260 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
261
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
262 # - .
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
263 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
264 package Schema::Property;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
265 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
266 our @ISA = qw(Schema::Member);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
267
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
268 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
269 DeclareProperty(Type => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
270 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
271
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
272 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
273 my ($this,$name,$type) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
274 $this->SUPER::CTOR($name);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
275
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
276 $this->{$Type} = $type or die new Exception("A type for the property must be specified",$name);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
277 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
278
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
279 sub isTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
280 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
281 return $this->{$Type}->isTemplate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
282 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
283
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
284 sub canInstantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
285 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
286 return $this->{$Type}->canInstantinate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
287 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
288
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
289 sub Instantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
290 my ($this,$Schema) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
291 return new Schema::Property($this->Name,$Schema->Instantinate($this->{$Type}));
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
292 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
293
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
294 sub Specialize {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
295 my ($this,$refParams,$TypeTable) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
296 return new Schema::Property($this->Name,$this->{$Type}->Specialize($refParams,$TypeTable));
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
297 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
298
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
299 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
300 package Schema::Type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
301 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
302 our @ISA = qw(Object);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
303
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
304 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
305 DeclareProperty(Name => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
306 DeclareProperty(Schema => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
307 DeclareProperty(Members => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
308 DeclareProperty(BaseList => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
309 DeclareProperty(Attributes => ACCESS_READ); #hash of attributes
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
310 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
311
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
312 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
313 my ($this,$argSchema,$name) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
314
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
315 $this->{$Name} = ref $name eq 'Schema::TypeName' ? $name : new Schema::TypeName($name);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
316 $this->{$Schema} = $argSchema;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
317 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
318
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
319 sub isTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
320 0;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
321 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
322
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
323 sub Equals {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
324 my ($this,$other) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
325 if (UNIVERSAL::isa($other,'Schema::Type')) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
326 return ($this->Name->CanonicalName eq $other->Name->CanonicalName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
327 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
328 return 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
329 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
330 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
331
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
332 sub CreateProperty {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
333 my ($this,$PropName,$TypeName) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
334
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
335 $PropType = $this->_ResolveType($TypeName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
336
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
337 return new Schema::Property($PropName,$PropType);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
338 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
339
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
340 sub AddBase {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
341 my ($this,$type) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
342
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
343 $type = $this->_ResolveType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
344
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
345 not $type->isType($this) or die new Exception('Cant derive from the class which is derived from self', $this->Name->CanonicalName, $type->Name->CanonicalName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
346
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
347 push @{$this->{$BaseList}},$type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
348 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
349
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
350 sub isType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
351 my ($this,$type,$maxlevel) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
352
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
353 return 0 if defined $maxlevel and $maxlevel < 0;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
354 my $typeName = UNIVERSAL::isa($type,'Schema::Type') ? $type->Name : $type ;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
355
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
356 return (
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
357 $this->{$Name}->CanonicalName eq $typeName->CanonicalName ?
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
358 1
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
359 :
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
360 scalar (grep {$_->isType($typeName,defined $maxlevel ? $maxlevel - 1 : undef)} $this->BaseList)
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
361 );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
362 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
363
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
364 sub ValidateType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
365 my ($this,$type) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
366
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
367 die new Exception('Can\'t use an unspecialized template',$type->Name->CanonicalName) if ($type->isa('Schema::TypeTemplate'));
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
368
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
369 if ($type->isTemplate and not $type->canInstantinate) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
370 die new Exception('Cant use a not fully specialized template in a simple type',$type->Name->CanonicalName, $this->Name->Name) if not $this->isTemplate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
371
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
372 my %Params = map {$_->Name->Name() , 1} @{$this->Parameters};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
373 my @Unresolved = grep {not $Params{$_->Name->Name}} @{$type->Parameters()};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
374
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
375 die new Exception('Not all parameters can be rsolved',map {$_->Name->Name} @Unresolved) if @Unresolved;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
376 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
377 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
378
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
379 sub InsertProperty {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
380 my ($this,$PropName,$PropType) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
381
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
382 $PropType = $this->_ResolveType($PropType);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
383
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
384 my $prop = new Schema::Property($PropName,$PropType);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
385
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
386 push @{$this->{$Members}}, $prop;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
387
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
388 return $prop;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
389 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
390
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
391 sub AddMember {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
392 my ($this,$member) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
393
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
394 push @{$this->{$Members}},$member;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
395 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
396
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
397 sub GetTypeTable {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
398 my $this = shift;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
399 return $this->{$Schema};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
400 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
401
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
402 sub _ResolveType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
403 my ($this,$type) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
404 if ($type->isa('Schema::TypeName')) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
405 $type = $type->Resolve($this->GetTypeTable());
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
406 } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
407 $this->ValidateType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
408 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
409 die new Exception('Invalid type',$type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
410 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
411
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
412 $type = $this->{$Schema}->Instantinate($type) if ($type->isTemplate and $type->canInstantinate and not $this->isTemplate);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
413 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
414 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
415
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
416 sub ListMembers {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
417 my ($this,%options) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
418
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
419 my @members;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
420
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
421 if ($options{'foreign'}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
422 push @members, $_->isa('Schema::Type') ? $_->ListMembers(%options) : () foreach @{$this->{$BaseList} ? $this->{$BaseList} : []};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
423 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
424 push @members, @{$this->{$Members} ? $this->{$Members} : []};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
425
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
426 return @members;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
427 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
428
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
429 sub FindMembers {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
430 my ($this,$memberName,%options) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
431
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
432 my @members = grep { $_->Name eq $memberName} @{$this->{$Members} ? $this->{$Members} : []};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
433
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
434 if ($options{'deep'}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
435 push @members,$_->ListMembers(%options) foreach @{$this->{$BaseList} ? $this->{$BaseList} : []};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
436 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
437
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
438 if(wantarray) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
439 return @members;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
440 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
441 return shift @members;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
442 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
443 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
444
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
445 sub SetAttributes {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
446 my ($this,%attributes) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
447
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
448 while (my ($key,$value) = each %attributes) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
449 $this->{$Attributes}{$key} = $value;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
450 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
451 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
452
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
453 sub GetAttribute {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
454 my ($this,$name) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
455
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
456 return $this->{$Attributes}{$name};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
457 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
458
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
459 sub _dump {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
460 my ($this) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
461 return $this->Name->CanonicalName;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
462 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
463
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
464 sub Dispose {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
465 my ($this) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
466
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
467 undef %{$this};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
468 $this->SUPER::Dispose;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
469 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
470
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
471 # -
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
472 package Schema::Template;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
473 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
474 our @ISA = qw(Schema::Type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
475
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
476 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
477 DeclareProperty(Parameters => ACCESS_READ);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
478 DeclareProperty(LocalTypes => ACCESS_NONE);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
479
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
480 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
481
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
482 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
483 my ($this,$Schema,$name,@args) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
484 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
485 $this->SUPER::CTOR($Schema,$name);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
486
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
487 $this->{$Parameters} = [ map {new Schema::Parameter($_) } @args ];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
488 my $TypeTable = new Schema::TypeTable($Schema);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
489 $TypeTable->RegisterType($_) foreach @{$this->{$Parameters} };
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
490 $this->{$LocalTypes} = $TypeTable;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
491 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
492
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
493 sub GetTypeTable {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
494 my ($this) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
495 return $this->{$LocalTypes};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
496 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
497
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
498 sub isTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
499 1;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
500 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
501
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
502 sub Specialize {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
503 my ($this,$refArgs,$TypeTable) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
504
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
505 my @specializedList = map {$_->Specialize($refArgs)} @{$this->{$Parameters}};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
506
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
507 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
508 my $specializedType;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
509
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
510 if ($TypeTable) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
511 my $TypeName = new Schema::TypeName($this->Name->Name,map {$_->Name} @specializedList);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
512
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
513 if(my $specializedType = $TypeTable->ResolveType($TypeName)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
514 return $specializedType;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
515 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
516 $specializedType = new Schema::TemplateSpec($this->Name->Name, @specializedList );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
517 $TypeTable->RegisterType($specializedType);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
518 return $specializedType;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
519 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
520 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
521 return new Schema::TemplateSpec($this->Name->Name, @specializedList );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
522 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
523 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
524
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
525 sub canInstantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
526 0;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
527 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
528
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
529 # .
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
530 # =
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
531 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
532 sub Instantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
533 my ($this,$refArgs,$instance) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
534
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
535 my %ParamInstances;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
536 my @TemplateListNames;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
537
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
538 foreach my $param (@{$this->{$Parameters}}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
539 my $type = $refArgs->{$param->Name->Name};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
540 die new Exception("Parameter not specified",$param->Name->Name) if not $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
541 if ($type->isTemplate) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
542 if ($type->canInstantinate) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
543 $type = $this->Schema->Instantinate($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
544 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
545 die new Exception("Parameter must be a fully speciazlied type",$param->Name->Name);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
546 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
547 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
548
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
549 $ParamInstances{$param->Name->Name} = $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
550 push @TemplateListNames, $type->Name;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
551 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
552
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
553 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
554 # ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
555
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
556 $instance = $this->Schema->CreateType( new Schema::TypeName($this->Name->Name,@TemplateListNames) ) if not $instance;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
557
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
558 $instance->SetAttributes(%{$this->Attributes}) if $this->Attributes;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
559 $instance->SetAttributes(
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
560 TemplateInstance => {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
561 Template => $this,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
562 Parameters => \%ParamInstances
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
563 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
564 );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
565
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
566 foreach my $Ancestor ($this->BaseList) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
567 $instance->AddBase(
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
568 $Ancestor->isTemplate ?
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
569 ( $Ancestor->canInstantinate ?
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
570 $this->Schema->Instantinate($Ancestor)
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
571 :
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
572 $this->Schema->Instantinate($Ancestor->Specialize(\%ParamInstances,$this->GetTypeTable))
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
573 )
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
574 :
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
575 $Ancestor
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
576 );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
577 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
578
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
579 foreach my $Member ($this->Members) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
580 $instance->AddMember(
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
581 $Member->isTemplate ?
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
582 ($Member->canInstantinate ?
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
583 $Member->Instantinate($this->Schema)
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
584 :
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
585 $Member->Specialize(\%ParamInstances,$this->GetTypeTable)->Instantinate($this->Schema)
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
586 )
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
587 :
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
588 $Member
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
589 );
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
590 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
591
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
592 return $instance;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
593 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
594
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
595 sub _ResolveType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
596 my ($this,$type) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
597 if ($type->isa('Schema::TypeName')) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
598 $type = $type->Resolve($this->GetTypeTable());
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
599 if (not $this->{$LocalTypes}->ResolveType($type->Name)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
600 $this->{$LocalTypes}->RegisterType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
601 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
602 } elsif ($type->isa('Schema::Type') or $type->isa('Schema::TemplateSpec')) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
603 $this->ValidateType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
604 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
605 die new Exception('Invalid type',$type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
606 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
607
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
608 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
609 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
610
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
611
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
612 package Schema;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
613 use strict;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
614 use Common;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
615 our @ISA = qw(Schema::TypeTable);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
616
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
617 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
618 DeclareProperty(PendingInstances => ACCESS_NONE);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
619 DeclareProperty(UnresolvedTypes => ACCESS_NONE);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
620 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
621
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
622 sub CTOR {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
623
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
624 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
625
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
626 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
627 sub ResolveType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
628 my ($this,$TypeName,$DoNotCreate) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
629
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
630 if (my $type = $this->SUPER::ResolveType($TypeName)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
631 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
632 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
633 if (not $TypeName->isTemplateSpec and not $DoNotCreate) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
634 $type = new Schema::Type($this,$TypeName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
635 $this->RegisterType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
636 $this->{$UnresolvedTypes}->{$TypeName->CanonicalName} = $TypeName;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
637 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
638 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
639 return undef;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
640 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
641 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
642 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
643
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
644 sub CreateType {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
645 my ($this,$TypeName) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
646
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
647 $TypeName = new Schema::TypeName($TypeName) if ref $TypeName ne 'Schema::TypeName';
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
648
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
649 if (my $type = $this->SUPER::ResolveType($TypeName)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
650 if ($this->{$UnresolvedTypes}->{$TypeName->CanonicalName}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
651 delete $this->{$UnresolvedTypes}->{$TypeName->CanonicalName};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
652 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
653 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
654 die new Exception("Type already exists",$TypeName->CanonicalName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
655 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
656 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
657 $type = new Schema::Type($this,$TypeName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
658 $this->SUPER::RegisterType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
659 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
660 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
661 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
662
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
663 sub CreateTemplate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
664 my ($this,$TemplateName,@ParamNames) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
665
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
666 die new Exception("Parameters required for the template") if not @ParamNames;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
667
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
668 if (ref $TemplateName eq 'Schema::TypeName') {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
669 die new Exception('Template specialization is not valid name for a new template',$TemplateName->CanonicalName) if $TemplateName->isTemplateSpec;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
670 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
671 $TemplateName = new Schema::TypeName($TemplateName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
672 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
673
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
674 if (my $type = $this->SUPER::ResolveType($TemplateName)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
675 die new Exception('Type already exists');
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
676 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
677 $type = new Schema::Template($this,$TemplateName,@ParamNames);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
678 $this->SUPER::RegisterType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
679 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
680 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
681 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
682
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
683 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
684 # , PendingInstances
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
685 sub Instantinate {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
686 my ($this,$TemplateSpec) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
687
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
688 # : T m_var; real_type m_var; ,
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
689 #
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
690 return $TemplateSpec if not $TemplateSpec->isTemplate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
691
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
692 die new Exception('Only a template specialization can be instantinated') if ref $TemplateSpec ne 'Schema::TemplateSpec';
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
693 die new Exception('Only fully specialized template can be instantinated') if not $TemplateSpec->canInstantinate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
694
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
695 my $TypeName = $TemplateSpec->Name;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
696
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
697 if (my $type = $this->SUPER::ResolveType($TypeName)) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
698 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
699 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
700 $type = new Schema::Type($this,$TypeName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
701 $this->SUPER::RegisterType($type);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
702 push @{$this->{$PendingInstances}},[$TemplateSpec,$type];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
703 return $type;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
704 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
705 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
706
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
707 sub Close {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
708 my ($this) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
709
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
710 if (keys %{$this->{$UnresolvedTypes}}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
711 die new Exception('Some type definitions are absent',keys %{$this->{$UnresolvedTypes}});
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
712 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
713
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
714 if ($this->{$PendingInstances}) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
715 while( my $ref = shift @{$this->{$PendingInstances}} ) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
716 my ($spec,$instance) = @$ref;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
717 if (my $typeTemplate = $this->SUPER::ResolveType( new Schema::TypeName($spec->Name->Name) )) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
718 die new Exception('Can\'t instantinate a specialization of the simple type',$instance->Name->CanonicalName) if not $typeTemplate->isTemplate;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
719 if (scalar(@{$typeTemplate->Parameters}) == scalar(@{$spec->TemplateList})) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
720 my @Params = @{$typeTemplate->Parameters};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
721 $typeTemplate->Instantinate({map { (shift @Params)->Name->Name, $_ } @{$spec->TemplateList}},$instance);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
722 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
723 die new Exception('A template parameters doesn\'t match to the specialization list',$instance->Name->CanonicalName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
724 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
725 } else {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
726 die new Exception('Can\'t instantinate a specialization, the specified template isn\'t found', $instance->Name->CanonicalName);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
727 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
728 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
729
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
730 delete $this->{$PendingInstances};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
731 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
732 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
733
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
734 sub EnumTypes {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
735 my ($this,%options) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
736
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
737 return grep { ($_->isTemplate and not $options{'skip_templates'}) or (not $_->isTemplate and not $options{'skip_classes'}) } $this->_ListTypes;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
738 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
739
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
740 sub Dispose {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
741 my ($this) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
742
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
743 delete $this->{$UnresolvedTypes};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
744
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
745 $this->SUPER::Dispose;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
746 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
747
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
748 1;