Mercurial > pub > Impl

changeset 28:6d33f75c6e1f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
ORM in works
author Sergey
date Mon, 19 Oct 2009 04:13:54 +0400
parents b544a772b654
children 37160f7c8edb
files Lib/IMPL/ORM/Entity.pm Lib/IMPL/ORM/Helpers.pm Lib/IMPL/ORM/Object.pm Lib/IMPL/ORM/Schema.pm Lib/IMPL/ORM/Schema/Entity.pm Lib/IMPL/ORM/Schema/Field.pm Lib/IMPL/ORM/Schema/Relation.pm Lib/IMPL/ORM/Schema/Relation/HasMany.pm Lib/IMPL/ORM/Schema/Relation/HasOne.pm Lib/IMPL/ORM/Schema/Relation/Subclass.pm _test/Test/DOM/Schema.pm _test/Test/ORM/Schema.pm impl.kpf
diffstat 13 files changed, 358 insertions(+), 23 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/ORM/Entity.pm	Fri Oct 16 16:37:53 2009 +0400
+++ b/Lib/IMPL/ORM/Entity.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -16,7 +16,13 @@
 sub CTOR {
     my ($this,$class,$schema) = @_;
     
-    
+    $this->{$Class} = $class;
+    (my $name = $class) =~ s/::/_/g;
+    $this->{$Name} = $name;
+    $this->Schema = $schema;
+    $this->{$Values} = {
+        map {$_->{name},{type => $_->{type}, virtual => $_->{virtual}}} @$schema
+    };
 }
 
 sub Store;
@@ -26,19 +32,17 @@
     my ($this,$prop,$value) = @_;
     
     if ( my $container = $this->{$Values}{$prop} ) {
-        if ($container->{type} eq 'SCALAR') {
-            
-        } else {
-            
-        }
-        
+        $container->{oldValue} = $container->{value};
+        $container->{value} = $value;
     } else {
         die new IMPL::InvalidOperationException("Property not found",$this->Name,$prop);
     }
 }
 
 sub Get {
+    my ($this,$prop) = @_;
     
+    return $this->{$Values}{$prop}{value};
 }
 
 1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Helpers.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,24 @@
+package IMPL::ORM::Helpers;
+use strict;
+use warnings;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(&Map &Box);
+
+sub Map($$) {
+    my ($TKey,$TValue) = @_;
+    
+    $TKey =~ s/:://g;
+    $TValue =~ s/:://g;
+    
+    return "IMPL::ORM::Map::${TKey}${TValue}";
+}
+
+sub Box($) {
+    my ($TValue) = @_;
+    $TValue =~ s/:://g;
+    return "IMPL::ORM::Box::$TValue";
+}
+
+1;
--- a/Lib/IMPL/ORM/Object.pm	Fri Oct 16 16:37:53 2009 +0400
+++ b/Lib/IMPL/ORM/Object.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -7,9 +7,15 @@
 use IMPL::Class::Property::Direct;
 
 require IMPL::ORM::Entity;
+require IMPL::ORM::Schema::Entity;
+require IMPL::ORM::Schema::Field;
+require IMPL::ORM::Schema::Relation::HasMany;
+require IMPL::ORM::Schema::Relation::HasOne;
+require IMPL::ORM::Schema::Relation::Subclass;
 
 BEGIN {
     private _direct property _entities => prop_all;
+    public property objectType => prop_all;
 }
 
 my %schemaCache;
@@ -36,18 +42,19 @@
     return $this->{$_entities}{$class} ? $this->{$_entities}{$class}->Get($prop,$value) : undef;
 }
 
-sub _PropertyImplementor {
-    'IMPL::ORM::Property'
+#sub _PropertyImplementor {
+#    'IMPL::ORM::Property'
+#}
+
+sub entityName {
+    (my $self = ref $_[0] || $_[0]) =~ s/::/_/g;
+    return $self;
 }
 
 sub ormGetSchema {
-    my ($self) = @_;
-    
-    my $class = ref $self || $self;
+    my ($self,$dataSchema) = @_;
     
-    return $schemaCache{$class} if $schemaCache{$class};
-    
-    my %schema;
+    my $schema = IMPL::ORM::Schema::Entity->new($self->entityName);
     
     foreach my $ormProp (
         $self->get_meta(
@@ -55,17 +62,22 @@
             sub {
                 UNIVERSAL::isa($_->Implementor, 'IMPL::ORM::Property' )
             },
-            1
+            0
         )
     ){
-        push @{$schema{$ormProp->Class}},{
-            name => $ormProp->Name,
-            virtual => $ormProp->Virtual,
-            type => $ormProp->Type
-        };
+        if ($ormProp->Mutators & prop_list) {
+            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);
+            $schema->appendChild( new IMPL::ORM::Schema::Relation::HasMany($ormProp->Name, $type->entityName) );
+        } elsif (my $type = $dataSchema->isValueType($ormProp->Type,'IMPL::ORM::Object')) {
+            $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$type) );
+        } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) {
+            $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName));
+        } else {
+            die new IMPL::Exception('Uexpected error due building schema for a class', $ormProp->Class, $ormProp->Name);
+        }
     }
     
-    return ($schemaCache{$class} = \%schema);
+    return $schema;
 }
 
 1;
@@ -79,4 +91,7 @@
 Базовый объект для реляционного отображения,
 содержит в себе реляционные записи представляющие данный объект.
 
+Каждый класс отображается в определенную сущность. Сущности хранят
+состояние объектов в том виде в котором удобно записывать в реляционную базу.
+
 =cut
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,64 @@
+package IMPL::ORM::Schema;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Document);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property mapValueTypes => prop_get | owner_set;
+    public property mapReferenceTypes => prop_get | owner_set;
+}
+
+sub CTOR {
+    my ($this ) = @_;
+    $this->mapValueTypes({});
+    $this->mapReferenceTypes({});
+}
+
+# return an entity for the specified typename
+# makes forward declaration if nesessary
+sub resolveType {
+    my ($this,$typeName) = @_;
+    
+    $this = ref $this ? $this : $this->instance;
+    
+    if (my $entity = $this->mapReferenceTypes->{$typeName}) {
+        return $entity;
+    } elsif (UNIVERSAL::isa($typeName,'IMPL::ORM::Object')) {
+        return $this->declareReferenceType($typeName);
+    } else {
+        return undef;
+    }
+}
+
+# returns valuetype name
+sub isValueType {
+    my ($this,$typeName) = @_;
+    
+    $this = ref $this ? $this : $this->instance;
+    
+    return $this->mapValueTypes->{$typeName};
+}
+
+my %instances;
+sub instance {
+    my ($class) = @_;
+    
+    return ($instances{$class} || ($instances{$class} = $class->new));
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+Схема данных, представляет собой DOM документ, элементами которой
+являются сущности.
+
+Каждый узел - это описание сущности.
+
+=cut
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/Entity.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,24 @@
+package IMPL::ORM::Schema::Entity;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Node);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property entityName => prop_get | owner_set;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Node' => sub {
+        nodeName => 'Entity'
+    }
+);
+
+sub CTOR {
+    my ($this,$name) = @_;
+
+    $this->entityName($name);
+}
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/Field.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,28 @@
+package IMPL::ORM::Schema::Field;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Node);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property fieldName => prop_get | owner_set;
+    public property fieldType => prop_get | owner_set;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Node' => sub { nodeName => 'Field' }
+);
+
+sub CTOR {
+    my ($this,$name,$type) = @_;
+    
+    $this->fieldName($name) or die new IMPL::InvalidArgumentException('A name is required for the field');
+    $this->fieldType($type) or die new IMPL::InvalidArgumentException('A type is required for the field');
+}
+
+sub canHaveChildren {
+    0;
+}
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/Relation.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,12 @@
+package IMPL::ORM::Schema::Relation;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Node);
+
+our %CTOR =(
+    'IMPL::DOM::Node' => sub { nodeName => $_[0] }
+);
+
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/Relation/HasMany.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,27 @@
+package IMPL::ORM::Schema::Relation::HasMany;
+use strict;
+use warnings;
+
+use base qw(IMPL::ORM::Schema::Relation);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property target => prop_get | owner_set;
+    public property name => prop_get | owner_set;
+}
+
+our %CTOR = (
+    'IMPL::ORM::Schema::Relation' => sub { 'HasMany' }
+);
+
+sub CTOR {
+    my ($this,$name,$target) = @_;
+    $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation');
+    $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name);
+}
+
+sub canHaveChildren {
+    0;
+}
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/Relation/HasOne.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,28 @@
+package IMPL::ORM::Schema::Relation::HasOne;
+use strict;
+use warnings;
+
+use base qw(IMPL::ORM::Schema::Relation);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property target => prop_get | owner_set;
+    public property name => prop_get | owner_set;
+}
+
+our %CTOR = (
+    'IMPL::ORM::Schema::Relation' => sub { 'HasOne' }
+);
+
+sub CTOR {
+    my ($this,$name,$target) = @_;
+    $this->name($name) or die new IMPL::InvalidArgumentException('A name is required for this relation');
+    $this->target($target) or die new IMPL::InvalidArgumentException('A target is required for this relation',$name);
+}
+
+sub canHaveChildren {
+    0;
+}
+
+
+1;
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/Relation/Subclass.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,26 @@
+package IMPL::ORM::Schema::Relation::Subclass;
+use strict;
+use warnings;
+
+use base qw(IMPL::ORM::Schema::Relation);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property base => prop_get | owner_set;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Node' => sub { 'Subclass' }
+);
+
+sub CTOR {
+    my ($this,$base) = @_;
+    
+    $this->base($base) or die new IMPL::InvalidArgumentException('A base is required for this relation');
+}
+
+sub canHaveChildren {
+    0;
+}
+
+1;
--- a/_test/Test/DOM/Schema.pm	Fri Oct 16 16:37:53 2009 +0400
+++ b/_test/Test/DOM/Schema.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -20,7 +20,7 @@
 
 test AutoverifyMetaSchema => sub {
     my $metaSchema = IMPL::DOM::Schema->MetaSchema();
-    
+
     if (my @errors = $metaSchema->Validate($metaSchema)) {
         failed "Self verification failed", map $_ ? $_->Message : 'unknown', @errors;
     }
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/ORM/Schema.pm	Mon Oct 19 04:13:54 2009 +0400
@@ -0,0 +1,57 @@
+package Test::ORM::Schema;
+use strict;
+use warnings;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw();
+
+package Test::ORM::Schema::Data::User;
+use base qw(IMPL::ORM::Object);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property Name => prop_all, { type => 'String' }; # Field
+    public property Id => prop_all, { type => 'String' }; # Field
+    public property Roles => prop_all | prop_list, { type=> 'Test::ORM::Schema::Data::Role'}; # HasMany
+}
+
+package Test::ORM::Schema::Data::Role;
+use base qw(IMPL::ORM::Object);
+use IMPL::Class::Property;
+
+BEGIN {
+    public property Name => prop_all, { type => 'String' }; # Field
+}
+
+package Test::ORM::Schema::Data::Session;
+use base qw(IMPL::ORM::Object);
+use IMPL::Class::Property;
+use IMPL::ORM::Helpers qw(Map);
+
+BEGIN {
+    public property Id => prop_get, { type => 'String' }; # Field
+    public property User => prop_get, { type => 'Test::ORM::Schema::Data::User' }; # HasOne
+    public property Data => prop_all, { type => Map( 'String','String' ) }; # HasOne
+    public property AccessTime => prop_get { type => 'DateTime' }; # Field
+}
+
+package Test::ORM::Schema::Data;
+use base qw(IMPL::ORM::Schema);
+
+__PACKAGE__->usePrefix(__PACKAGE__);
+__PACKAGE__->Classes qw(
+    User
+    Role
+    Session
+);
+
+__PACKAGE__->ValueTypes (
+    'String' => 'IMPL::ORM::Value::String',
+    'DateTime' => 'IMPL::ORM::Value::DateTime',
+    'Integer' => 'IMPL::ORM::Value::Inetger',
+    'Float' => 'IMPL::ORM::Value::Float',
+    'Decimal' => 'IMPL::ORM::Value::Decimal'
+);
+
+1;
--- a/impl.kpf	Fri Oct 16 16:37:53 2009 +0400
+++ b/impl.kpf	Mon Oct 19 04:13:54 2009 +0400
@@ -456,6 +456,32 @@
 </preference-set>
   <string id="lastInvocation">default</string>
 </preference-set>
+<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Test/ORM/Schema.pm">
+<preference-set id="Invocations">
+<preference-set id="default">
+  <string id="cookieparams"></string>
+  <string id="cwd"></string>
+  <long id="debugger.io-port">9011</long>
+  <string id="documentRoot"></string>
+  <string id="executable-params"></string>
+  <string relative="path" id="filename">_test/Test/ORM/Schema.pm</string>
+  <string id="getparams"></string>
+  <string id="language">Perl</string>
+  <string id="mpostparams"></string>
+  <string id="params"></string>
+  <string id="postparams"></string>
+  <string id="posttype">application/x-www-form-urlencoded</string>
+  <string id="request-method">GET</string>
+  <boolean id="show-dialog">1</boolean>
+  <boolean id="sim-cgi">0</boolean>
+  <boolean id="use-console">0</boolean>
+  <string id="userCGIEnvironment"></string>
+  <string id="userEnvironment"></string>
+  <string id="warnings">enabled</string>
+</preference-set>
+</preference-set>
+  <string id="lastInvocation">default</string>
+</preference-set>
 <preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/Web.t">
 <preference-set id="Invocations">
 <preference-set id="default">