# HG changeset patch
# User Sergey
# Date 1257774579 -10800
# Node ID 0004faa276dc44d462fbf6e38092c9b024227102
# Parent  56cef8e3cda61d1612ff630f8a80a106136c1456
small fixes, some new tests

diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/Object/Abstract.pm
--- a/Lib/IMPL/Object/Abstract.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/Object/Abstract.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -65,13 +65,17 @@
     return (ref $self || $self);
 }
 
-sub DESTROY {
-    if ($MemoryLeakProtection and $Cleanup) {
-        my $this = shift;
-        warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
-    }
+sub isDisposed {
+    0;
 }
 
+#sub DESTROY {
+#    if ($MemoryLeakProtection and $Cleanup) {
+#        my $this = shift;
+#        warn sprintf("Object leaks: %s of type %s %s",$this->can('ToString') ? $this->ToString : $this,ref $this,UNIVERSAL::can($this,'_dump') ? $this->_dump : '');
+#    }
+#}
+
 sub END {
     $Cleanup = 1;
 }
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/Object/Disposable.pm
--- a/Lib/IMPL/Object/Disposable.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/Object/Disposable.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -31,4 +31,9 @@
     return if $AUTOLOAD eq __PACKAGE__.'::DESTROY';
     die new IMPL::Exception('Object have been disposed',$AUTOLOAD);
 }
+
+sub isDisposed {
+    1;
+}
+
 1;
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Schema.pm
--- a/Lib/IMPL/SQL/Schema.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/SQL/Schema.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -1,12 +1,14 @@
 use strict;
 package IMPL::SQL::Schema;
 
-use base qw(IMPL::Object IMPL::Object::Disposable);
+use base qw(IMPL::Object IMPL::Object::Disposable IMPL::Object::Autofill);
 use IMPL::Class::Property;
 use IMPL::Class::Property::Direct;
 
 require IMPL::SQL::Schema::Table;
 
+__PACKAGE__->PassThroughArgs;
+
 BEGIN {
     public _direct property Version => prop_get;
     public _direct property Name => prop_get;
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Schema/Constraint.pm
--- a/Lib/IMPL/SQL/Schema/Constraint.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/SQL/Schema/Constraint.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -34,7 +34,7 @@
     
     my %Columns = map { $_, 1} @Columns;
     
-    return scalar(grep { $Columns{$_->Name} } $this->Columns) == scalar(@Columns);
+    return scalar(grep { $Columns{$_->Name} } @{$this->Columns}) == scalar(@Columns);
 }
 
 sub UniqName {
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm
--- a/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -25,10 +25,10 @@
     scalar (@ReferencedColumns) == scalar(@{$this->Columns}) or die new Exception('A foreing key columns doesn\'t match refenced columns');
     my @ColumnsCopy = @ReferencedColumns;
     
-    die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->Type->isSame((shift @ColumnsCopy)->Type)} $this->Columns;
+    die new Exception('A foreing key columns doesn\'t match refenced columns') if grep { not $_->Type->isSame((shift @ColumnsCopy)->Type)} @{$this->Columns};
     
     @ColumnsCopy = @ReferencedColumns;
-    die new Exception('The foreign key must match to the primary key of the referenced table',$this->Name) if grep { not $_->Type->isSame(shift(@ColumnsCopy)->Type)} $ForeingPK->Columns;
+    die new Exception('The foreign key must match to the primary key of the referenced table',$this->Name) if grep { not $_->Type->isSame(shift(@ColumnsCopy)->Type)} @{$ForeingPK->Columns};
     
     $this->{$ReferencedPrimaryKey} = $ForeingPK;
     
@@ -38,7 +38,7 @@
 sub Dispose {
     my ($this) = @_;
 
-    $this->{$ReferencedPrimaryKey}->DisconnectFK($this) if not $this->{$ReferencedPrimaryKey}->isa('Object::Disposed');
+    $this->{$ReferencedPrimaryKey}->DisconnectFK($this) if not $this->{$ReferencedPrimaryKey}->isDisposed;
     delete $this->{$ReferencedPrimaryKey};
     
     $this->SUPER::Dispose;
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Schema/Constraint/Index.pm
--- a/Lib/IMPL/SQL/Schema/Constraint/Index.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/SQL/Schema/Constraint/Index.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -8,7 +8,7 @@
     my $this = shift;
     
     my %colnames;
-    not grep { $colnames{$_}++ } $this->Columns or die new Exception('Each column in the index can occur only once');
+    not grep { $colnames{$_}++ } @{$this->Columns} or die new Exception('Each column in the index can occur only once');
 }
 
 1; 
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Schema/Constraint/Unique.pm
--- a/Lib/IMPL/SQL/Schema/Constraint/Unique.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/SQL/Schema/Constraint/Unique.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -1,5 +1,7 @@
-package IMPL::SQL::Schema::Constraint::PrimaryKey;
+package IMPL::SQL::Schema::Constraint::Unique;
 use strict;
 use base qw(IMPL::SQL::Schema::Constraint::Index);
 
+__PACKAGE__->PassThroughArgs;
+
 1;
\ No newline at end of file
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Schema/Table.pm
--- a/Lib/IMPL/SQL/Schema/Table.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/Lib/IMPL/SQL/Schema/Table.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -153,7 +153,7 @@
     my ($this,$table,@ColumnList) = @_;
     $table->PrimaryKey or die new IMPL::InvalidOperationException('The referenced table must have a primary key');
     my $constraintName = $this->{$Name}.'_'.$table->Name.'_FK_'.join('_',map {ref $_ ? $_->Name : $_} @ColumnList);
-    $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(Name => $constraintName, Table => $this,Columns => \@ColumnList, ReferencedTable => $table, ReferencedColumns => scalar($table->PrimaryKey->Columns)));
+    $this->AddConstraint(new IMPL::SQL::Schema::Constraint::ForeignKey(Name => $constraintName, Table => $this,Columns => \@ColumnList, ReferencedTable => $table, ReferencedColumns => $table->PrimaryKey->Columns));
 }
 
 sub Dispose {
diff -r 56cef8e3cda6 -r 0004faa276dc Lib/IMPL/SQL/Types.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/SQL/Types.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -0,0 +1,35 @@
+package IMPL::SQL::Types;
+use strict;
+use warnings;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(&Integer &Varchar &Float &Real &Text &Binary);
+
+require IMPL::SQL::Schema::Type;
+
+sub Integer() {
+    return IMPL::SQL::Schema::Type->new(Name => 'INTEGER');
+}
+
+sub Varchar($) {
+    return IMPL::SQL::Schema::Type->new(Name => 'VARCHAR', Length => shift);
+}
+
+sub Float($) {
+    return IMPL::SQL::Schema::Type->new(Name => 'FLOAT', Scale => shift);
+}
+
+sub Real() {
+    return IMPL::SQL::Schema::Type->new(Name => 'REAL');
+}
+
+sub Text() {
+    return IMPL::SQL::Schema::Type->new(Name => 'TEXT');
+}
+
+sub Binary() {
+    return IMPL::SQL::Schema::Type->new(Name => 'BINARY');
+}
+
+1;
diff -r 56cef8e3cda6 -r 0004faa276dc _test/SQL.t
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/SQL.t	Mon Nov 09 16:49:39 2009 +0300
@@ -0,0 +1,17 @@
+#!/usr/bin/perl -w
+use strict;
+use lib '../Lib';
+use lib '.';
+
+use IMPL::Test::Plan;
+use IMPL::Test::TAPListener;
+
+my $plan = new IMPL::Test::Plan qw(
+    Test::SQL::Schema
+);
+
+$plan->AddListener(new IMPL::Test::TAPListener);
+$plan->Prepare();
+$plan->Run();
+
+1;
\ No newline at end of file
diff -r 56cef8e3cda6 -r 0004faa276dc _test/Test/SQL/Schema.pm
--- a/_test/Test/SQL/Schema.pm	Mon Nov 09 01:39:31 2009 +0300
+++ b/_test/Test/SQL/Schema.pm	Mon Nov 09 16:49:39 2009 +0300
@@ -5,4 +5,106 @@
 use base qw(IMPL::Test::Unit);
 __PACKAGE__->PassThroughArgs;
 
+use IMPL::Class::Property;
+use IMPL::Class::Property::Direct;
+
+use IMPL::Test qw(test shared failed);
+
+BEGIN {
+    shared public property schemaDB => prop_all;
+}
+
+require IMPL::SQL::Schema;
+require IMPL::SQL::Schema::Constraint::Unique;
+
+use IMPL::SQL::Types qw(Integer Varchar);
+
+test CreateSchema => sub {
+    my ($this) = @_;
+    
+    my $schema = new IMPL::SQL::Schema(Name => 'dbTest', Version => 1) or failed "Failed to create schema";
+    
+    failed "Failed to set a schema name" unless $schema->Name eq 'dbTest';
+    failed "Failed to set a schema version" unless $schema->Version == 1;
+    
+    $this->schemaDB($schema);
+};
+
+test AddTable => sub {
+    my ($this) = @_;
+    
+    my $table = $this->schemaDB->AddTable({Name => 'User'}) or failed "Failed to add a table to the schema";
+    $table->InsertColumn({
+        Name => 'Id',
+        Type => Integer
+    });
+    $table->InsertColumn({
+        Name => 'Login',
+        Type => Varchar(255)
+    });
+    $table->InsertColumn({
+        Name => 'DisplayName',
+        CanBeNull => 1,
+        Type => Varchar(255)
+    });
+    $table->InsertColumn({
+        Name => 'RoleId',
+        CanBeNull => 1,
+        Type => Integer
+    });
+    
+    $table->SetPrimaryKey('Id');
+    
+    my $colCount = @{$table->Columns};
+    
+    failed "Failed to add columns", "Expected: 4", "Got: ".$colCount unless $colCount == 4;
+    failed "Failed to set a primary key" unless $table->PrimaryKey;
+    
+    my $table2 = $this->schemaDB->AddTable({Name => 'Role'});
+    $table2->InsertColumn({
+        Name => 'Id',
+        Type => Integer
+    });
+    $table2->InsertColumn({
+        Name => 'Description',
+        Type => Varchar(255)
+    });
+    $table2->InsertColumn({
+        Name => 'ObsoleteId',
+        Type => Integer
+    });
+    
+    $table2->SetPrimaryKey('Id');
+    
+    $table->LinkTo($table2,'RoleId');
+};
+
+test Constraints => sub {
+    my ($this) = @_;
+    
+    my $table = $this->schemaDB->Tables->{Role} or failed "Failed to get a table";
+    
+    my $constraint = $table->AddConstraint(
+        new IMPL::SQL::Schema::Constraint::Unique(
+            Name => 'Role_ObsoleteId_Uniq',
+            Table => $table,
+            Columns => ['ObsoleteId']
+        )
+    ) or failed "Failed to add constraint";
+    
+    failed "Failed to retrieve a constraint" unless ($table->GetColumnConstraints('ObsoleteId'))[0] == $constraint;
+    
+    $table->RemoveColumn('ObsoleteId',1);
+    
+    failed "A constraint remains alive after column deletion" unless $constraint->isDisposed;
+    
+};
+
+test Dispose => sub {
+    my ($this) = @_;
+    
+    $this->schemaDB->Dispose();
+};
+
+
 1;
diff -r 56cef8e3cda6 -r 0004faa276dc impl.kpf
--- a/impl.kpf	Mon Nov 09 01:39:31 2009 +0300
+++ b/impl.kpf	Mon Nov 09 16:49:39 2009 +0300
@@ -430,6 +430,32 @@
 </preference-set>
   <string id="lastInvocation">default</string>
 </preference-set>
+<preference-set idref="66c7d414-175f-45b6-92fe-dbda51c64843/_test/SQL.t">
+<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/SQL.t</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/Test/DOM/Node.pm">
 <preference-set id="Invocations">
 <preference-set id="default">