# HG changeset patch
# User Sergey
# Date 1258988227 -10800
# Node ID d660fb38b7cc324d931084ab9140e7be334ef2f5
# Parent  c2e7f7c96bcdb787407f71c86504fda2cab7b1f1
small fixes

ORM shema to SQL schema transformation

diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/DOM/Node.pm
--- a/Lib/IMPL/DOM/Node.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/DOM/Node.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -208,7 +208,7 @@
     # this method is called by the parent node on his children, so we need no to check parent
     $this->{$document} = $this->{$parentNode}->document;
     
-    # prevetn ciclyc
+    # prevent cyclic
     weaken($this->{$document}) if $this->{$document};
     
     $_->_updateDocRefs foreach @{$this->{$childNodes}};
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/DOM/Property.pm
--- a/Lib/IMPL/DOM/Property.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/DOM/Property.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -25,21 +25,21 @@
     die new IMPL::InvalidOperationException("Custom mutators are not allowed","${class}::$name") if ref $mutators;
     if (($mutators & prop_all) == prop_all) {
         *{"${class}::$name"} = sub {
-            $_[0]->Property($name,@_[1..$#_]);
+            $_[0]->nodeProperty($name,@_[1..$#_]);
         };
         $propInfo->canGet(1);
         $propInfo->canSet(1);
     } elsif( $mutators & prop_get ) {
         *{"${class}::$name"} = sub {
             die new IMPL::InvalidOperationException("This is a readonly property", "${class}::$name") if @_>1;
-            $_[0]->Property($name);
+            $_[0]->nodeProperty($name);
         };
         $propInfo->canGet(1);
         $propInfo->canSet(0);
     } elsif( $mutators & prop_set ) {
         *{"${class}::$name"} = sub {
             die new IMPL::InvalidOperationException("This is a writeonly property", "${class}::$name") if @_<2;
-            $_[0]->Property($name,@_[1..$#_]);
+            $_[0]->nodeProperty($name,@_[1..$#_]);
         };
         $propInfo->canGet(0);
         $propInfo->canSet(1);
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/DOM/Transform.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/DOM/Transform.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -0,0 +1,33 @@
+package IMPL::DOM::Transform;
+use strict;
+use warnings;
+
+use base qw(IMPL::Transform);
+
+__PACKAGE__->PassThroughArgs;
+
+sub GetClassForObject {
+    my ($this,$object) = @_;
+    
+    if (my $class = ref $object) {
+        if (UNIVERSAL::isa($object,'IMPL::DOM::Node')) {
+            return $object->nodeName;
+        } else {
+            return $class;
+        }
+    } else {
+        return undef;
+    }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+Преобразование для DOM документа
+
+=cut
\ No newline at end of file
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/ORM/Object.pm
--- a/Lib/IMPL/ORM/Object.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/ORM/Object.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -72,7 +72,7 @@
             $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) );
+            $schema->appendChild( new IMPL::ORM::Schema::Field($ormProp->Name,$type->name) );
         } elsif (my $entity = $dataSchema->resolveType($ormProp->Type)) {
             # отношение ссылка
             $schema->appendChild( new IMPL::ORM::Schema::Relation::HasOne($ormProp->Name,$entity->entityName));
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/ORM/Schema.pm
--- a/Lib/IMPL/ORM/Schema.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/ORM/Schema.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -5,15 +5,16 @@
 use base qw(IMPL::DOM::Document);
 use IMPL::Class::Property;
 require IMPL::ORM::Schema::Entity;
+require IMPL::ORM::Schema::ValueType;
 
 our %CTOR = (
-    'IMPL::DOM::Document' => sub { nodeName => 'Schema' }
+    'IMPL::DOM::Document' => sub { nodeName => 'ORMSchema' }
 );
 
 BEGIN {
-    public property mapValueTypes => prop_get | owner_set;
-    public property mapReferenceTypes => prop_get | owner_set;
-    public property mapPending => prop_get | owner_set;
+    private property mapValueTypes => prop_all;
+    private property mapReferenceTypes => prop_all;
+    private property mapPending => prop_all;
     public property prefix => prop_get | owner_set; 
 }
 
@@ -45,6 +46,8 @@
     
     my $entity = new IMPL::ORM::Schema::Entity($typeName);
     
+    $this->appendChild($entity);
+    
     $this->mapPending->{$typeName} = $entity;
     
     return $this->mapReferenceTypes->{$typeName} = $entity;
@@ -53,7 +56,7 @@
 sub _addReferenceType {
     my ($this,$className) = @_;
     
-    $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this,delete $this->mapPending->{$className});
+    $this->mapReferenceTypes->{$className} = $className->ormGetSchema($this,delete $this->mapPending->{$className} || $this->appendChild(new IMPL::ORM::Schema::Entity($className)));
 }
 
 # returns valuetype name
@@ -65,6 +68,12 @@
     return $this->mapValueTypes->{$typeName};
 }
 
+sub ReferenceTypes {
+    my ($this) = @_;
+    
+    values %{$this->mapReferenceTypes};
+}
+
 my %instances;
 sub instance {
     my ($class) = @_;
@@ -77,7 +86,12 @@
     
     $this = ref $this ? $this : $this->instance;
     
-    $this->mapValueTypes->{$_} = $classes{$_} foreach keys %classes;
+    $this->mapValueTypes->{$_} = $this->appendChild(
+        IMPL::ORM::Schema::ValueType->new(
+            name => $_,
+            mapper => $classes{$_}
+        )
+    ) foreach keys %classes;
 }
 
 sub Classes {
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/ORM/Schema/Field.pm
--- a/Lib/IMPL/ORM/Schema/Field.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/ORM/Schema/Field.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -8,6 +8,7 @@
 BEGIN {
     public property fieldName => prop_get | owner_set;
     public property fieldType => prop_get | owner_set;
+    public property fieldNullbale => prop_get | owner_set;
 }
 
 our %CTOR = (
@@ -15,10 +16,11 @@
 );
 
 sub CTOR {
-    my ($this,$name,$type) = @_;
+    my ($this,$name,$type,$nullable) = @_;
     
     $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');
+    $this->fieldNullbale(1) if $nullable;
 }
 
 sub canHaveChildren {
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/ORM/Schema/TransformToSQL.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/TransformToSQL.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -0,0 +1,159 @@
+package IMPL::ORM::Schema::TransformToSQL;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Transform);
+use IMPL::Class::Property;
+use IMPL::SQL::Types qw(DateTime Varchar Integer Float Text Binary);
+
+require IMPL::SQL::Schema;
+
+BEGIN {
+    public property Types => prop_get | owner_set;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Transform' => sub {
+        ORMSchema => \&ORMSchemaTransform,
+        Entity => \&EntityTransform,
+        Field => \&FieldTransform,
+        HasOne => \&HasOneTransform,
+        HasMany => \&HasManyTransform,
+        Subclass => \&SubclassTransform
+    }
+);
+
+sub CTOR {
+    my ($this,$refTypeMap) = @_;
+    
+    $this->Types($refTypeMap) or die new IMPL::InvalidArgumentException("A reference to the type map hash is required");
+}
+
+sub ORMSchemaTransform {
+    my ($this,$node) = @_;
+    
+    my $schema = IMPL::SQL::Schema->new(Name => ref $node);
+    
+    my @constraints;
+    
+    my %ctx = (Schema => $schema);
+    
+    # all tables
+    foreach my $entity ($node->ReferenceTypes) {
+        $schema->AddTable($this->Transform($entity,\%ctx));
+        push @constraints, $entity->selectNodes(sub {$_->isa('IMPL::ORM::Schema::Relation')});
+    }
+    
+    # establish relations
+    $this->Transform($_,\%ctx) foreach @constraints;
+    
+    return $schema;
+}
+
+sub EntityTransform {
+    my ($this,$node,$ctx) = @_;
+    
+    my $table = IMPL::SQL::Schema::Table->new(Name => $node->entityName, Schema => $ctx->{Schema});
+    
+    $this->MakePrimaryKey($table);
+    
+    $table->InsertColumn( $this->Transform($_,$ctx)) foreach$node->selectNodes('Field');
+    
+    return $table;
+}
+
+sub FieldTransform {
+    my ($this,$field,$ctx) = @_;
+    
+    return {
+        Name => $field->fieldName,
+        Type => $this->MapType($field->fieldType) || die new IMPL::Exception("Can't get map a rom schema type to the SQL type",$field->fieldType),
+        CanBeNull => $field->fieldNullable
+    };
+}
+
+sub HasOneTransform {
+    my ($this,$relation,$ctx) = @_;
+    
+    my $sqlSchema = $ctx->{Schema};
+    my $table = $sqlSchema->Tables->{$relation->parentNode->entityName};
+    my $tableForeign = $sqlSchema->Tables->{$relation->target};
+    my $prefix = $relation->name;
+    
+    my @fkColumns = map
+        $table->InsertColumn({
+            Name => $prefix . $_->Name,
+            Type => $_->Type,
+            CanBeNull => 1
+        }),
+        @{$tableForeign->PrimaryKey->Columns};
+        
+    $table->LinkTo($tableForeign,@fkColumns);    
+}
+
+sub HasManyTransform {
+    my ($this,$relation,$ctx) = @_;
+    
+    #similar to HasOne
+    
+    my $sqlSchema = $ctx->{Schema};
+    my $table = $sqlSchema->Tables->{$relation->parentNode->entityName};
+    my $tableForeign = $sqlSchema->Tables->{$relation->target};
+    my $prefix = $table->Name . '_' . $relation->name;
+    
+    my @fkColumns = map
+        $tableForeign->InsertColumn({
+            Name => $prefix . $_->Name,
+            Type => $_->Type,
+            CanBeNull => 1
+        }),
+        @{$table->PrimaryKey->Columns};
+        
+    $tableForeign->LinkTo($table,@fkColumns);    
+}
+
+sub SubclassTransform {
+    # actually this rlations has only ligical implementation
+}
+
+sub MapType {
+    my ($this,$typeName) = @_;
+    
+    $this->Types->{$typeName} || die new IMPL::Exception("Can't map a type",$typeName);
+}
+
+sub MakePrimaryKey {
+    my ($this,$table) = @_;
+    
+    $table->InsertColumn( {Name => '_Id', Type => Integer } );
+    $table->SetPrimaryKey('_Id');
+}
+
+{
+    my $std;
+    sub Std {
+        $std ||= __PACKAGE__->new({
+            String => Varchar(255),
+            DateTime => DateTime,
+            Integer => Integer,
+            Float => Float(24),
+            Decimal => Float(53),
+            Real => Float(24),
+            Binary => Binary,
+            Text => Text
+        });
+    }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 SYNOPSIS
+
+my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Default->Transform(Data::Schema->instance);
+
+=cut
+
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/ORM/Schema/ValueType.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/ORM/Schema/ValueType.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -0,0 +1,22 @@
+package IMPL::ORM::Schema::ValueType;
+use strict;
+use warnings;
+
+use base qw(IMPL::DOM::Node);
+use IMPL::Class::Property;
+use IMPL::DOM::Property qw(_dom);
+
+BEGIN {
+    public _dom property name => prop_all;
+    public _dom property mapper => prop_all;
+}
+
+our %CTOR = (
+    'IMPL::DOM::Node' => sub {
+        my %args = @_;
+        $args{nodeName} = 'ValueType';
+        %args;
+    }
+);
+
+1;
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/SQL/Types.pm
--- a/Lib/IMPL/SQL/Types.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/SQL/Types.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -4,7 +4,7 @@
 
 require Exporter;
 our @ISA = qw(Exporter);
-our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary);
+our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary &DateTime);
 
 require IMPL::SQL::Schema::Type;
 
@@ -32,4 +32,8 @@
     return IMPL::SQL::Schema::Type->new(Name => 'BINARY');
 }
 
+sub DateTime() {
+    return IMPL::SQL::Schema::Type->new(Name => 'DATETIME');
+}
+
 1;
diff -r c2e7f7c96bcd -r d660fb38b7cc Lib/IMPL/Transform.pm
--- a/Lib/IMPL/Transform.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/Lib/IMPL/Transform.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -20,29 +20,35 @@
 }
 
 sub Transform {
-    my ($this,$object) = @_;
+    my ($this,$object,@args) = @_;
     
     if (not ref $object) {
         die new IMPL::Exception("There is no the template for a plain value in the transform") unless $this->{$Plain};
         my $template = $this->{$Plain};
-        return $this->$template($object);
+        return $this->$template($object,@args);
     } else {
     
         my $template = $this->MatchTemplate($object) || $this->Default or die new IMPL::Transform::NoTransformException(ref $object);
     
-        return $this->$template($object);
+        return $this->$template($object,@args);
     }
 }
 
 sub MatchTemplate {
     my ($this,$object) = @_;
-    my $class = ref $object;
+    my $class = $this->GetClassForObject( $object );
     
     foreach my $tClass ( keys %{$this->Templates || {}} ) {
         return $this->Templates->{$tClass} if ($tClass eq $class);
     }
 }
 
+sub GetClassForObject {
+    my ($this,$object) = @_;
+    
+    return ref $object;
+}
+
 package IMPL::Transform::NoTransformException;
 use base qw(IMPL::Exception);
 
@@ -76,7 +82,8 @@
 
 my $result = $t->Transform($obj);
 
-=head1 Summary
-Преобразует данные содержащиеся в форме в реальные объекты используя специальное преобразование.
+=head1 DESCRIPTION
+
+Преобразование одного объекта к другому, например даных к их представлению.
 
 =cut
\ No newline at end of file
diff -r c2e7f7c96bcd -r d660fb38b7cc _test/Test/ORM/Schema.pm
--- a/_test/Test/ORM/Schema.pm	Mon Nov 23 00:59:06 2009 +0300
+++ b/_test/Test/ORM/Schema.pm	Mon Nov 23 17:57:07 2009 +0300
@@ -7,6 +7,8 @@
 
 use IMPL::Test qw(test failed);
 
+require IMPL::ORM::Schema::TransformToSQL;
+
 test ExtractClassSchema => sub {
     my ($this) = @_;
     
@@ -24,6 +26,12 @@
     return 1;
 };
 
+test TransformDataSchema => sub {
+    my $sqlSchema = IMPL::ORM::Schema::TransformToSQL->Std->Transform(Test::ORM::Schema::Data->instance)
+        or failed("Failed to transform a schema");
+    $sqlSchema->Dispose;
+};
+
 
 package Test::ORM::Schema::Data::User;
 use base qw(IMPL::ORM::Object);
@@ -59,11 +67,11 @@
 use base qw(IMPL::ORM::Schema);
 
 __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'
+    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'
 );
 
 __PACKAGE__->usePrefix(__PACKAGE__);