Mercurial > pub > Impl

changeset 164:eb3e9861a761

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
SQL traits in progress
author wizard
date Mon, 28 Mar 2011 01:36:24 +0400
parents 6ce1f052b90a
children 76515373dac0
files Lib/IMPL/Class/Meta.pm Lib/IMPL/Object/Abstract.pm Lib/IMPL/Object/Fields.pm Lib/IMPL/SQL/Schema.pm Lib/IMPL/SQL/Schema/Traits.pm Lib/IMPL/lang.pm _test/Test/Object/Fields.pm _test/object.t
diffstat 8 files changed, 636 insertions(+), 33 deletions(-) [+]
line wrap: on
line diff
--- a/Lib/IMPL/Class/Meta.pm	Tue Mar 15 02:32:42 2011 +0300
+++ b/Lib/IMPL/Class/Meta.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -69,7 +69,7 @@
 			$self = ref $self || $self;
 			
 			if ($class ne $self) {
-				$self->class_data_accessor( $name => $_[0]);
+				$self->static_accessor( $name => $_[0]); # define own class data
 			} else {
 				$value = $_[0];
 			}
--- a/Lib/IMPL/Object/Abstract.pm	Tue Mar 15 02:32:42 2011 +0300
+++ b/Lib/IMPL/Object/Abstract.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -61,12 +61,6 @@
     $self->$_(@_) foreach @{$cacheCTOR{$class} || cache_ctor($class)};
 }
 
-sub superCTOR {
-    my $this = shift;
-
-    warn "The mehod is deprecated, at " . caller;
-}
-
 sub toString {
     my $self = shift;
     
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Object/Fields.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -0,0 +1,26 @@
+package IMPL::Object::Fields;
+use strict;
+use warnings;
+
+use base qw(IMPL::Object::Abstract);
+
+sub new {
+	my $class = shift;
+	
+	$class = ref $class || $class;
+	
+	my $this = fields::new($class);
+	$this->callCTOR(@_);
+	
+	return $this;
+}
+
+sub surrogate {
+	my $class = shift;
+	
+	$class = ref $class || $class;
+	
+	return fields::new($class);
+}
+
+1;
\ No newline at end of file
--- a/Lib/IMPL/SQL/Schema.pm	Tue Mar 15 02:32:42 2011 +0300
+++ b/Lib/IMPL/SQL/Schema.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -58,6 +58,17 @@
 	UNIVERSAL::isa($table,'IMPL::SQL::Schema::Table') ? $table : $this->{$Tables}{$table};
 }
 
+sub GetTable {
+	my ($this,$tableName) = @_;
+	return $this->{$Tables}{$tableName};
+}
+
+sub RenameTable {
+	my ($this,$oldName,$newName) = @_;
+	
+	
+}
+
 sub Dispose {
     my ($this) = @_;
     
--- a/Lib/IMPL/SQL/Schema/Traits.pm	Tue Mar 15 02:32:42 2011 +0300
+++ b/Lib/IMPL/SQL/Schema/Traits.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -3,56 +3,369 @@
 use IMPL::_core::version;
 use IMPL::Exception();
 
-use base qw(IMPL::Object IMPL::Object::Autofill);
+use IMPL::base qw(IMPL::Object);
 
-# this is a base class for all table traits 
+###################################################
+
 package IMPL::SQL::Traits::Table;
+use IMPL::base qw(IMPL::Object::Fields);
 
-our @ISA = qw(IMPL::SQL::Traits);
+use fields qw(
+	name
+	columns
+	constraints
+	options
+);
+
+sub CTOR {
+	my ($this,$table,$columns,$constraints,$options) = @_;
+	
+	$this->{name} = $table;
+	$this->{columns} = $columns;
+	$this->{constraints} = $constraints;
+	$this->{options} = $options;
+}
+
+###################################################
+
+package IMPL::SQL::Traits::Column;
+use IMPL::base qw(IMPL::Object::Fields);
+
+use fields qw(
+	name
+	type
+	isNullable
+	defaultValue
+	tag
+);
+
+sub CTOR {
+	my ($this, $name, $type, %args) = @_;
+	
+	$this->{name} = $name or die new IMPL::InvalidArgumentException("name");
+	$this->{type} = $type or die new IMPL::InvalidArgumentException("type");
+	$this->{isNullable} = $args{isNullable} if exists $args{isNullable};
+	$this->{defaultValue} = $args{defaultValue} if exists $args{defaultValue};
+	$this->{tag} = $args{tag} if exists $args{tag};
+}
+
+##################################################
+
+package IMPL::SQL::Traits::Constraint;
+use IMPL::base qw(IMPL::Object::Fields);
+
+use fields qw(
+	name
+	tableName
+	columns
+);
+
+sub CTOR {
+	my ($this, $name, $tableName, $columns) = @_;
+	
+	$this->{name} = $name;
+	$this->{tableName} = $tableName;
+	$$this->{columns} = $columns;
+}
+
+##################################################
+
+package IMPL::SQL::Traits::PrimaryKey;
+
+use IMPL::base qw(IMPL::SQL::Traits::Constraint);
+
+__PACKAGE__->PassThroughArgs;
+
+##################################################
+
+package IMPL::SQL::Traits::Index;
+
+use IMPL::base qw(IMPL::SQL::Traits::Constraint);
+
+__PACKAGE__->PassThroughArgs;
+
+##################################################
+
+package IMPL::SQL::Traits::Unique;
+
+use IMPL::base qw(IMPL::SQL::Traits::Constraint);
+
+__PACKAGE__->PassThroughArgs;
 
+##################################################
+
+package IMPL::SQL::Traits::ForeignKey;
+
+use IMPL::base qw(IMPL::SQL::Traits::Constraint);
+use fields qw(
+	foreignTable
+	foreignColumns
+);
+
+our %CTOR = (
+	'IMPL::SQL::Traits::Constraint' => sub { @_[0..2] }
+);
+
+sub CTOR {
+	my ($this,$foreignTable,$foreignColumns) = @_[0,4,5];
+	
+	$this->{foreignTable} = $foreignTable;
+	$this->{foreignColunms} = $foreignColumns;
+}
+ 
+
+##################################################
+
+package IMPL::SQL::Traits::CreateTable;
+
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
+use IMPL::lang;
+
+BEGIN {
+	public property table => prop_get | owner_set;
+}
+
+sub CTOR {
+	my ($this,$table) = @_;
+	
+	die new IMPL::InvalidArgumentException("table", "An object of IMPL::SQL::Traits::Table type is required")
+		unless is $table, typeof IMPL::SQL::Traits::Table;
+	
+	$this->table($table);
+}
+
+sub apply {
+	my ($this,$schema) = @_;
+	
+	return 0 if ( $schema->GetTable( $this->table->{name} ) );
+	
+	$schema->AddTable($this->table);
+	return 1;
+}
+
+##################################################
+
+package IMPL::SQL::Traits::DropTable;
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
+
+BEGIN {
+	public property tableName => prop_get | owner_set;
+}
+
+sub CTOR {
+	my ($this,$tableName) = @_;
+	
+	$this->tableName($tableName) or die new IMPL::InvalidArgumentException("tableName is required");
+}
+
+sub apply {
+	my ($this,$schema) = @_;
+	
+	return 0 if $schema->GetTable( $this->tableName );
+	
+	$schema->RemoveTable($this->tableName);
+	
+	return 1;
+}
+
+##################################################
+
+package IMPL::SQL::Traits::RenameTable;
+use IMPL::base qw(IMPL::SQL::Traits);
 use IMPL::Class::Property;
 
 BEGIN {
-	public property tableName => prop_all;
+	public property tableName => prop_get | owner_set;
+	public property tableNewName => prop_get | owner_set;
+}
+
+sub CTOR {
+	my ($this, $oldName, $newName) = @_;
+	
+	$this->tableName($oldName) or die new IMPL::InvalidArgumentException("A table name is required");
+	$this->tableNewName($newName) or die new  IMPL::InvalidArgumentException("A new table name is required");
+}
+
+sub apply {
+	my ($this,$schema) = @_;
+	
+	return 0 if not $schema->GetTable($this->tableName) or $schema->GetTable($this->tableNewName);
+	
+	$this->RenameTable($this->tableName, $this->tableNewName);
+	
+	return 1;
+}
+
+#################################################
+
+package IMPL::SQL::Traits::AlterTableAddColumn;
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
+use IMPL::lang;
+
+BEGIN {
+	public property tableName => prop_get | owner_set;
+	public property column => prop_get | owner_set;
 }
 
-sub verify {
-	my ($this, $schema) = @_;
+sub CTOR {
+	my ($this,$tableName,$column) = @_;
+	
+	$this->tableName($tableName) or die new IMPL::InvalidArgumentException("A table name is required");
+	
+	die new IMPL::InvalidArgumentException("A column should be a IMPL::SQL::Traits::Column object")
+		unless is $column, typeof IMPL::SQL::Traits::Column;
+		
+	$this->column($column);
+}
+
+sub apply {
+	my ($this,$schema) = @_;
+	
+	my $table = $schema->GetTable($this->tableName) or return 0;
+	
+	return 0 if $table->GetColumn( $this->column->{name} );
+	
+	$table->AddColumn($this->column);
+	
+	return 1;
+}
+
+#################################################
+
+package IMPL::SQL::Traits::AlterTableDropColumn;
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
+
+BEGIN {
+	public property tableName => prop_get | owner_set;
+	public property columnName => prop_get | owner_set;
+}
+
+sub CTOR { 
+	my ($this,$table,$column) = @_;
+	
+	$this->tableName($table) or die new IMPL::InvalidArgumentException(tableName => "A table name should be specified");
+	$this->columnName($column) or die new IMPL::InvalidArgumentException(columnName => "A column name should be specified");
+}
+
+sub apply {
+	my ($this,$schema) = @_;
+	
+	local $@;
+	
+	return eval {
+		$schema->GetTable($this->tableName)->RemoveColumn($this->columnName);
+		return 1;
+	} || 0;
 }
 
-package IMPL::SQL::Traits::Table::Create;
+#################################################
 
-our @ISA = qw(IMPL::SQL::Traits::Table);
+package IMPL::SQL::Traits::AlterTableChangeColumn;
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
 
-package IMPL::SQL::Traits::Table::Drop;
-
-our @ISA = qw(IMPL::SQL::Traits::Table);
+BEGIN {
+	public property tableName => prop_get | owner_set;
+	public property columnName => prop_get | owner_set;
+	public property columnType => prop_get | owner_set;
+	public property defaultValue => prop_get | owner_set;
+	public property isNullable => prop_get | owner_set;
+	public property options => prop_get | owner_set;
+}
 
-package IMPL::SQL::Traits::Table::AlterAttributes;
-
-our @ISA = qw(IMPL::SQL::Traits::Table);
+sub CTOR {
+	my ($this, $table,$column,%args) = @_;
+	
+	$this->tableName($table) or die new IMPL::InvalidArgumentException(tableName => "A table name is required");
+	$this->columnName($column) or die new IMPL::InvalidArgumentException(columnName => "A column name is required");
+	
+	$this->$_($args{$_})
+		for (grep exists $args{$_}, qw(columnType defaultValue isNullable options));
+}
 
-package IMPL::SQL::Traits::Table::AlterName;
+sub apply {
+	my ($this,$schema) = @_;
+	
+	local $@;
+	
+	return eval {
+		my $column = $schema->GetTable($this->tableName)->GetColumn($this->columnName);
+		$column->SetType($this->columnType) if $this->columnType;
+		$column->SetNullable($this->isNullable) if $this->isNullable;
+		$column->SetDefaultValue($this->defaultValue) if $this->defaultValue;
+		$column->SetOptions($this->options) if $this->options;
+		
+		return 1;
+	} || 0;
+}
 
-our @ISA = qw(IMPL::SQL::Traits::Table);
+#################################################
 
+package IMPL::SQL::Traits::AlterTableAddConstraint;
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
+use IMPL::lang;
 
-
-package IMPL::SQL::Traits::Column;
+BEGIN {
+	public property tableName => prop_get | owner_set;
+	public property constraint => prop_get | owner_set;
+}
 
-our @ISA = qw(SQL::IMPL::Traits);
+sub CTOR {
+	my ($this,$table,$constraint) = @_;
+	
+	$this->tableName($table) or die new IMPL::InvalidArgumentException( tableName => "A table name is required");
+	
+	die new IMPL::InvalidArgumentException(constaraint => "A valid IMPL::SQL::Traits::Constarint is required")
+		unless is $constraint, typeof IMPL::SQL::Traits::Constraint;
+		
+	$this->constraint($constraint);
+}
 
-package IMPL::SQL::Traits::Column::Create;
+sub apply {
+	my ($this,$schema) = @_;
+	
+	local $@;
+	
+	return eval {
+		$schema->GetTable($this->tableName)->AddConstraint($this->constraint);
+		return 1;
+	} || 0;
+	
+}
 
-our @ISA = qw(IMPL::SQL::Traits::Column);
+#################################################
 
-package IMPL::SQL::Traits::Column::Drop;
+package IMPL::SQL::Traits::AlterTableDropConstraint;
+use IMPL::base qw(IMPL::SQL::Traits);
+use IMPL::Class::Property;
+
+BEGIN {
+	public property tableName => prop_get | owner_set;
+	public property constraintName => prop_get | owner_set;
+}
 
-our @ISA = qw(IMPL::SQL::Traits::Column);
+sub CTOR {
+	my ($this,$table,$constraint) = @_;
+	
+	die new IMPL::InvalidArgumentException( tableName => "A table name is required" ) unless $table;
+	die new IMPL::InvalidArgumentException( constraintName => "A constraint name is required" ) unless $constraint;
+}
 
-package IMPL::SQL::Traits::Column::Alter;
-
-our @ISA = qw(IMPL::SQL::Traits::Column);
+sub apply {
+	my ($this,$schema) = @_;
+	
+	my $table = $schema->GetTable($this->tableName) or return 0;
+	
+	return 0 unless $table->GetConstraint($this->constraintName);
+	
+	$table->RemoveConstraint($this->constraintName);
+	return 1;
+}
 
 
 1;
@@ -68,6 +381,195 @@
 =head1 DESCRIPTION
 
 Изменения схемы могу быть представлены в виде последовательности примитивных операций.
+Правила выполнения последовательности примитывных действий могут варьироваться
+в зависимости от процессора, который их выполняет. Например C<IMPL::SQL::Traits::Processor>.
 
+Данные, которые содержаться в примитивных операциях не могут существовать независимо от схемы.
+
+=head1 OPEARATIONS
+
+=head2 General
+
+Методы обще для всех примитивных операций.
+
+=over
+
+=item C<apply($schema)>
+
+Пытается приминить операцию к указанной схеме.
+
+Возвращаемое значение:
+
+=over
+
+=item C<true>
+
+Операция успешно применена к схеме.
+
+=item C<false>
+
+Операция не может быть применена к схеме.
+
+=back
+
+=back
+
+=head2 Primitive operations
+
+=over
+
+=item C<IMPL::SQL::Traits::CreateTable>
+
+Создает таблицу
+
+=over
+
+=item C<CTOR($table)>
+
+=item C<[get]table>
+
+C<IMPL::SQL::Traits::Table> - описание создаваемой таблицы
+
+=back
+
+=item C<IMPL::SQL::Traits::DropTable>
+
+Удалает таблицу по имени
+
+=over
+
+=item C<CTOR($tableName)>
+
+=item C<[get]tableName>
+
+Имя удаляемой таблицы
+
+=back
+
+=item C<IMPL::SQL::Traits::RenameTable>
+
+=over
+
+=item C<CTOR($tableName,$tableNewName)>
+
+=item C<[get]tableName>
+
+Имя таблицы, которую требуется переименовать
+
+=item C<[get]tableNewName>
+
+Новое имя таблицы
+
+=back
+
+=item C<IMPL::SQL::Traits::AlterTableAddColumn>
+
+Добавляет столбец в таблицу
+
+=over
+
+=item C<CTOR($tableName,$column)>
+
+=item C<[get]tableName>
+
+Имя таблицы в которую нужно добавить столбец
+
+=item C<[get]column>
+
+C<IMPL::SQL::Traits::Column> - описание столбца который нужно добавить 
+
+=back
+
+=item C<IMPL::SQL::Traits::AlterTableDropColumn>
+
+Удаляет столбец из таблицы
+
+=over
+
+=item C<CTOR($tableName,$columnName)>
+
+=item C<[get]tableName>
+
+Имя таблицы в которой нужно удалить столбец
+
+=item C<[get]columnName>
+
+Имя столбца для удаления
+
+=back
+
+=item C<IMPL::SQL::Traits::AlterTableChangeColumn>
+
+Меняет описание столбца
+
+=over
+
+=item C<CTOR($tableName,$columnName,%args)>
+
+C<%args> - хеш, ключами которого являются оставшиеся свойства создаваемого объекта.
+
+=item C<[get]tableName>
+
+Имя таблицы в которой находится столбец.
+
+=item C<[get]columnName>
+
+Имя столбца для изменения
+
+=item C<[get]columnType>
+
+Новый тип столбца. Не задан, если тип не меняется
+
+=item C<[get]defaultValue>
+
+Значение по умолчанию. Не задано, если не меняется
+
+=item C<[get]isNullable>
+
+Может ли столбец содержать C<NULL>. Не задано, если не меняется.
+
+=item C<[get]options>
+
+Хеш опций, не задан, если опции не меняются
+
+=back
+
+=item C<IMPL::SQL::Traits::AlterTableAddConstraint>
+
+Базовый класс для операций по добавлению ограничений
+
+=over
+
+=item C<CTOR($tableName,$constraint)>
+
+=item C<[get]tableName>
+
+Имя таблицы в которую добавляется ограничение.
+
+=item C<[get]constraint>
+
+C<IMPL::SQL::Traits::Constraint> - описние ограничения, которое нужно добавить.
+
+=back
+
+=item C<IMPL::SQL::Traits::AlterTableDropConstraint>
+
+Удаляет ограничение на таблицу
+
+=over
+
+=item C<CTOR($tableName,$constraintName)>
+
+=item C<[get]tableName>
+
+Имя таблицы в которой требуется удалить ограничение.
+
+=item C<[get]constraintName>
+
+Имя ограничения для удаления.
+
+=back
+
+=back
 
 =cut
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/lang.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -0,0 +1,15 @@
+package IMPL::lang;
+use strict;
+use warnings;
+
+use IMPL::base qw(Exporter);
+use IMPL::_core::version;
+
+
+our @EXPORT = qw(&is);
+
+sub is($$) {
+	eval { $_[0]->isa($_[1]) }
+}
+
+1;
\ No newline at end of file
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/_test/Test/Object/Fields.pm	Mon Mar 28 01:36:24 2011 +0400
@@ -0,0 +1,54 @@
+package Test::Object::Fields;
+use strict;
+use warnings;
+
+use base qw( IMPL::Test::Unit );
+use IMPL::Test qw(test failed cmparray);
+
+__PACKAGE__->PassThroughArgs;
+
+{
+	package Fields::Foo;
+	use base qw(IMPL::Object::Fields);
+	
+	use fields qw(name info);
+	
+	sub CTOR {
+		my ($this,$name,$info) = @_;
+		
+		$this->{name} = $name;
+		$this->{info} = $info;
+	}
+	
+	package Fields::Bar;
+	use base qw(Fields::Foo);
+	use fields qw(id);
+	
+	our %CTOR = (
+		'Fields::Foo' => sub {
+			my %args = @_;
+			Bar => $args{info};
+		}
+	);
+	
+	sub CTOR {
+		my ($this,%args) = @_;
+		
+		$this->{id} = $args{id};
+	}
+}
+
+test constructObject => sub {
+	my $obj = new Fields::Foo( Peter => '34-fg-78' );
+	
+	$obj->{name} eq 'Peter' or failed "A value of 'name' field is wrong","Expected: 'Peter'","Got: '$obj->{name}'";
+};
+
+test inheritance => sub {
+	my $obj = new Fields::Bar( id => '1ba356f', info => 'standard bar');
+	
+	$obj->{name} eq 'Bar' or failed "A value of 'name' property is wrong","Expected: 'Bar'","Got: '$obj->{name}'";
+	$obj->{id} eq '1ba356f' or failed "A value of 'id' property is wrong","Expected: '1ba356f'","Got: '$obj->{id}'";
+};
+
+1;
\ No newline at end of file
--- a/_test/object.t	Tue Mar 15 02:32:42 2011 +0300
+++ b/_test/object.t	Mon Mar 28 01:36:24 2011 +0400
@@ -10,6 +10,7 @@
 	Test::Class::Meta
     Test::Object::Common
     Test::Object::List
+    Test::Object::Fields
 );
 
 $plan->AddListener(new IMPL::Test::TAPListener);