Mercurial > pub > Impl
annotate Lib/IMPL/ORM/Object.pm @ 38:d660fb38b7cc
small fixes
ORM shema to SQL schema transformation
| author | Sergey |
|---|---|
| date | Mon, 23 Nov 2009 17:57:07 +0300 |
| parents | d59526f6310e |
| children | 32d2350fccf9 |
| rev | line source |
|---|---|
| 21 | 1 package IMPL::ORM::Object; |
| 2 use strict; | |
| 3 use warnings; | |
| 4 | |
| 27 | 5 use base qw(IMPL::Object); |
| 6 use IMPL::Class::Property; | |
| 7 use IMPL::Class::Property::Direct; | |
| 8 | |
| 9 require IMPL::ORM::Entity; | |
| 28 | 10 require IMPL::ORM::Schema::Entity; |
| 11 require IMPL::ORM::Schema::Field; | |
| 12 require IMPL::ORM::Schema::Relation::HasMany; | |
| 13 require IMPL::ORM::Schema::Relation::HasOne; | |
| 14 require IMPL::ORM::Schema::Relation::Subclass; | |
| 27 | 15 |
| 16 BEGIN { | |
| 17 private _direct property _entities => prop_all; | |
| 28 | 18 public property objectType => prop_all; |
| 27 | 19 } |
| 20 | |
| 21 my %schemaCache; | |
| 22 | |
| 23 sub CTOR { | |
| 24 my ($this) = @_; | |
| 25 | |
| 26 while ( my ($class,$schema) = $this->ormGetSchema ) { | |
| 27 $this->{$_entities}{$class} = new IMPL::ORM::Entity($class,$schema); | |
| 28 } | |
| 29 } | |
| 30 | |
| 31 sub ormStore { | |
| 32 my ($this,$class,$prop,$value) = @_; | |
| 33 | |
| 34 die IMPL::InvalidOperationException("Cannot find entity for the specified class",$class) unless $this->{$_entities}{$class}; | |
| 35 | |
| 36 $this->{$_entities}{$class}->Store($prop,$value); | |
| 37 } | |
| 21 | 38 |
| 27 | 39 sub ormGet { |
| 40 my ($this,$class,$prop,$value) = @_; | |
| 41 | |
| 42 return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef; | |
| 43 } | |
| 44 | |
| 30 | 45 sub _PropertyImplementor { |
| 46 'IMPL::ORM::PropertyImplementor' | |
| 47 } | |
| 28 | 48 |
| 49 sub entityName { | |
| 50 (my $self = ref $_[0] || $_[0]) =~ s/::/_/g; | |
| 51 return $self; | |
| 27 | 52 } |
| 53 | |
| 54 sub ormGetSchema { | |
| 30 | 55 my ($self,$dataSchema,$surrogate) = @_; |
| 27 | 56 |
| 30 | 57 my $schema = $surrogate || IMPL::ORM::Schema::Entity->new($self->entityName); |
| 27 | 58 |
| 29 | 59 # для текущего класса, проходим по всем свойствам |
| 27 | 60 foreach my $ormProp ( |
| 61 $self->get_meta( | |
| 62 'IMPL::Class::PropertyInfo', | |
| 63 sub { | |
| 30 | 64 UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::PropertyImplementor' ) |
| 27 | 65 }, |
| 28 | 66 0 |
| 27 | 67 ) |
| 68 ){ | |
| 28 | 69 if ($ormProp->Mutators & prop_list) { |
| 29 | 70 # отношение 1 ко многим |
| 28 | 71 my $type = $dataSchema->resolveType($ormProp->Type) or die new IMPL::InvalidOperationException("Failed to resolve a reference type due building schema for a class", $ormProp->Class, $ormProp->Name); |
| 72 $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) ); | |
| 73 } elsif (my $type = $dataSchema->isValueType($ormProp->Type,'IMPL::ORM::Object')) { | |
| 29 | 74 # поле |
| 38 | 75 $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$type->name) ); |
| 28 | 76 } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) { |
| 29 | 77 # отношение ссылка |
| 28 | 78 $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName)); |
| 79 } else { | |
| 29 | 80 # хз что. Скорее всего не удалось квалифицировать тип свойства не как ссылочный и как поле. |
|
31
d59526f6310e
Small fixes to Test framework (correct handlinf of the compilation errors in the test units)
Sergey
parents:
30
diff
changeset
|
81 die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name,$ormProp->Type); |
| 28 | 82 } |
| 27 | 83 } |
| 84 | |
| 29 | 85 # Формируем отношения наследования |
| 86 { | |
| 87 # локализуем прагму | |
| 88 no strict 'refs'; | |
| 89 | |
| 90 my $class = ref $self || $self; | |
| 91 | |
| 92 # по всем классам | |
| 93 foreach my $super (grep $_->isa(__PACKAGE__), @{"${class}::ISA"}) { | |
| 94 my $type = $dataSchema->resolveType($super) or die new IMPL::InvalidOperationException("Failed to resolve a super class due building schema for a class", $class, $super); | |
| 30 | 95 $schema->appendChild(new IMPL::ORM::Schema::Relation::Subclass($type)); |
| 29 | 96 } |
| 97 } | |
| 98 | |
| 28 | 99 return $schema; |
| 27 | 100 } |
| 21 | 101 |
| 102 1; | |
| 27 | 103 |
| 104 __END__ | |
| 105 | |
| 106 =pod | |
| 107 | |
| 108 =head1 DESCRIPTION | |
| 109 | |
| 110 Базовый объект для реляционного отображения, | |
| 111 содержит в себе реляционные записи представляющие данный объект. | |
| 112 | |
| 28 | 113 Каждый класс отображается в определенную сущность. Сущности хранят |
| 114 состояние объектов в том виде в котором удобно записывать в реляционную базу. | |
| 115 | |
| 27 | 116 =cut |