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