Mercurial > pub > Impl
changeset 271:56364d0c4b4f
+IMPL::SQL::Schema::MySQL: added basic support for MySQL
author | cin |
---|---|
date | Mon, 28 Jan 2013 02:43:14 +0400 |
parents | 3f59fd828d5f |
children | 47db27ed5b43 |
files | Lib/IMPL/SQL/Schema/Constraint.pm Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Lib/IMPL/SQL/Schema/Diff.pm Lib/IMPL/SQL/Schema/MySQL/CharType.pm Lib/IMPL/SQL/Schema/MySQL/EnumType.pm Lib/IMPL/SQL/Schema/MySQL/Formatter.pm Lib/IMPL/SQL/Schema/MySQL/Processor.pm Lib/IMPL/SQL/Schema/Processor.pm Lib/IMPL/SQL/Schema/Table.pm Lib/IMPL/SQL/Schema/Traits.pm Lib/IMPL/SQL/Schema/Traits/MysqlFormatter.pm Lib/IMPL/SQL/Schema/Traits/Processor.pm Lib/IMPL/lang.pm _test/Test/Class/Template.pm _test/Test/SQL/Diff.pm |
diffstat | 15 files changed, 1353 insertions(+), 260 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/SQL/Schema/Constraint.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint.pm Mon Jan 28 02:43:14 2013 +0400 @@ -2,7 +2,7 @@ use strict; use warnings; -use IMPL::lang qw(:declare is); +use IMPL::lang qw(:declare is isclass); use parent qw(IMPL::Object IMPL::Object::Disposable); @@ -29,7 +29,7 @@ sub ResolveColumn { my ($Table,$Column) = @_; - my $cn = UNIVERSAL::isa($Column,'IMPL::SQL::Schema::Column') ? $Column->name : $Column; + my $cn = is($Column,'IMPL::SQL::Schema::Column') ? $Column->name : $Column; my $resolved = $Table->GetColumn($cn); die new IMPL::InvalidOperationException("The column is not found in the table", $cn, $Table->name) if not $resolved; @@ -74,7 +74,7 @@ sub ResolveAlias { my ($self,$alias) = @_; - return is($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; + return isclass($alias, typeof IMPL::SQL::Schema::Constraint) ? $alias : $aliases{$alias}; } sub RegisterAlias {
--- a/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Constraint/ForeignKey.pm Mon Jan 28 02:43:14 2013 +0400 @@ -10,8 +10,8 @@ BEGIN { public _direct property referencedPrimaryKey => PROP_GET; - public _direct property OnDelete => PROP_GET; - public _direct property OnUpdate => PROP_GET; + public _direct property onDelete => PROP_GET; + public _direct property onUpdate => PROP_GET; } __PACKAGE__->PassThroughArgs; @@ -20,7 +20,7 @@ sub CTOR { my ($this,%args) = @_; - die new Eexception("Referenced table must be an instance of a table object") if not UNIVERSAL::isa($args{'referencedTable'},'IMPL::SQL::Schema::Table'); + die new Exception("Referenced table must be an instance of a table object") if not is($args{'referencedTable'},'IMPL::SQL::Schema::Table'); die new Exception("Referenced columns must be a not empty list of columns") if not UNIVERSAL::isa($args{'referencedColumns'},'ARRAY') or not scalar(@{$args{'referencedColumns'}}); @@ -38,6 +38,9 @@ $this->{$referencedPrimaryKey} = $ForeingPK; $ForeingPK->ConnectFK($this); + + $this->onUpdate($args{onUpdate}) if $args{onUpdate}; + $this->onDelete($args{onDelete}) if $args{onDelete}; } sub Dispose { @@ -52,8 +55,8 @@ sub SameValue { my ($this,$other) = @_; - uc $this->OnDelete eq uc $other->OnDelete or return 0; - uc $this->OnUpdate eq uc $other->OnUpdate or return 0; + uc $this->onDelete eq uc $other->onDelete or return 0; + uc $this->onUpdate eq uc $other->onUpdate or return 0; return $this->SUPER::SameValue($other); }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/Diff.pm Mon Jan 28 02:43:14 2013 +0400 @@ -0,0 +1,192 @@ +package IMPL::SQL::Schema::Diff; +use strict; +use warnings; +use IMPL::lang qw(:compare :hash is); + +use IMPL::SQL::Schema::Traits(); + +use IMPL::require { + Schema => 'IMPL::SQL::Schema', + ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', + PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', + UniqueConstraint =>'-IMPL::SQL::Schema::Constraint::Unique', + Index => '-IMPL::SQL::Schema::Constraint::Index', + TraitsForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', + TraitsPrimaryKey => '-IMPL::SQL::Schema::Traits::PrimaryKey', + TraitsUnique => '-IMPL::SQL::Schema::Traits::Unique', + TraitsIndex => '-IMPL::SQL::Schema::Traits::Index', + TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', + TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', + TraitsTable => '-IMPL::SQL::Schema::Traits::Table', + TraitsColumn => '-IMPL::SQL::Schema::Traits::Column', + TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', + TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', + TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', + TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', + TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn', + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' +}; + +sub Diff { + my ($self,$src,$dst) = @_; + + die ArgException->new( src => "A valid source schema is required") unless is($src,Schema); + die ArgException->new( dst => "A valid desctination schema is requried" ) unless is($src,Schema); + + my %dstTables = map { $_->name, $_ } $dst->GetTables; + + my @operations; + + foreach my $srcTable ( $src->GetTables) { + my $dstTable = delete $dstTables{$srcTable->name}; + + if (not $dstTable) { + # if a source table doesn't have a corresponding destination table, it should be deleted + push @operations, TraitsDropTable->new($srcTable->name); + } else { + # a source table needs to be updated + push @operations, $self->_DiffTables($srcTable,$dstTable); + } + + } + + foreach my $tbl ( values %dstTables ) { + push @operations, TraitsCreateTable->new( + TraitsTable->new( + $tbl->name, + [ map _Column2Traits($_), @{$tbl->columns} ], + [ map _Constraint2Traits($_), $tbl->GetConstraints()], + $tbl->{tag} + ) + ) + } + + return \@operations; +} + +sub _DiffTables { + my ($self,$src,$dst) = @_; + + my @dropConstraints; + my @createConstraints; + + my %srcConstraints = map { $_->name, $_ } $src->GetConstraints(); + my %dstConstraints = map { $_->name, $_ } $dst->GetConstraints(); + + foreach my $cnSrcName (keys %srcConstraints) { + if ( my $cnDst = delete $dstConstraints{$cnSrcName} ) { + unless ( $srcConstraints{$cnSrcName}->SameValue($cnDst) ) { + push @dropConstraints, + TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); + push @createConstraints, + TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); + } + } else { + push @dropConstraints,TraitsAlterTableDropConstraint->new( $src->name, $cnSrcName ); + } + } + + foreach my $cnDst (values %dstConstraints) { + push @createConstraints, + TraitsAlterTableAddConstraint->new( $dst->name, _Constraint2Traits($cnDst) ); + } + + my @deleteColumns; + my @addColumns; + my @updateColumns; + + my %dstColumnIndexes = map { + my $col = $dst->GetColumnAt($_); + ($col->name, { column => $col, index => $_ }) + } 0 .. $dst->ColumnsCount-1; + + my @columns; + + # remove old columns, mark for update changed columns + for( my $i=0; $i < $src->ColumnsCount; $i++) { + my $colSrc = $src->GetColumnAt($i); + + if ( my $infoDst = delete $dstColumnIndexes{$colSrc->name} ) { + $infoDst->{prevColumn} = $colSrc; + push @columns,$infoDst; + } else { + push @deleteColumns,TraitsAlterTableDropColumn->new($src->name,$colSrc->name); + } + } + + #insert new columns at specified positions + foreach ( sort { $a->{index} <=> $b->{index} } values %dstColumnIndexes ) { + splice(@columns,$_->{index},0,$_); + push @addColumns, TraitsAlterTableAddColumn->new($src->name, _Column2Traits( $_->{column}, position => $_->{index} )); + } + + # remember old indexes + for(my $i =0; $i< @columns; $i ++) { + $columns[$i]->{prevIndex} = $i; + } + + # reorder columns + @columns = sort { $a->{index} <=> $b->{index} } @columns; + + foreach my $info (@columns) { + if ($info->{prevColumn} && ( !$info->{column}->SameValue($info->{prevColumn}) or $info->{index}!= $info->{prevIndex} ) ) { + my $op = TraitsAlterTableChangeColumn->new($src->name,$info->{column}->name); + + $op->position( $info->{index} ) unless $info->{prevIndex} == $info->{index}; + $op->isNullable( $info->{column}->isNullable ) unless equals($info->{column}->isNullable,$info->{prevColumn}->isNullable); + $op->defaultValue( $info->{column}->defaultValue ) unless equals($info->{column}->defaultValue, $info->{prevColumn}->defaultValue); + + my $diff = hashDiff($info->{prevColumn}->tag,$info->{column}->tag); + $op->options($diff) if %$diff; + + push @updateColumns, $op; + } + } + + my @result = (@dropConstraints, @deleteColumns, @addColumns, @updateColumns, @createConstraints); + + return @result; +} + +sub _Column2Traits { + my ($column,%options) = @_; + + return TraitsColumn->new( + $column->name, + $column->type, + isNullable => $column->isNullable, + defaultValue => $column->defaultValue, + tag => $column->tag, + %options + ); +} + +sub _Constraint2Traits { + my ($constraint) = @_; + + my $map = { + ForeignKey , TraitsForeignKey, + PrimaryKey , TraitsPrimaryKey, + UniqueConstraint , TraitsUnique, + Index , TraitsIndex + }; + + my $class = $map->{$constraint->typeof} or die Exception->new("Can't map the constraint",$constraint->typeof); + + if ($class eq TraitsForeignKey) { + return $class->new( + $constraint->name, + [ map $_->name, $constraint->columns ], + $constraint->referencedPrimaryKey->table->name, + [ map $_->name, $constraint->referencedPrimaryKey->columns ] + ); + } else { + return $class->new( + $constraint->name, + [ map $_->name, $constraint->columns ] + ); + } +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/MySQL/CharType.pm Mon Jan 28 02:43:14 2013 +0400 @@ -0,0 +1,27 @@ +package IMPL::SQL::Schema::MySQL::CharType; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::SQL::Schema::Type' => '@_' + ], + props => [ + encoding => PROP_RO + ] +}; + +my @CHAR_TYPES = qw(VARCHAR CHAR); + +sub CTOR { + my ($this) = @_; + + die ArgException->new(name => "The specified name is invalid", $this->name) + unless grep uc($this->name) eq $_, @CHAR_TYPES; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/MySQL/EnumType.pm Mon Jan 28 02:43:14 2013 +0400 @@ -0,0 +1,23 @@ +package IMPL::SQL::Schema::MySQL::EnumType; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + base => [ + 'IMPL::SQL::Schema::Type' => '@_' + ], + props => [ + enumValues => PROP_RO | PROP_LIST + ] +}; + +our @ENUM_TYPES = qw(ENUM SET); + +sub CTOR { + my $this = shift; + + die ArgException->new(name => "The specified name is invalid", $this->name) + unless grep uc($this->name) eq $_, @ENUM_TYPES; +} + +1; \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/MySQL/Formatter.pm Mon Jan 28 02:43:14 2013 +0400 @@ -0,0 +1,559 @@ +package IMPL::SQL::Schema::MySQL::Formatter; +use strict; + +use IMPL::lang qw(is); +use IMPL::require { + Exception => 'IMPL::Exception', + OpException => '-IMPL::InvalidOperationException', + ArgException => '-IMPL::InvalidArgumentException', + PrimaryKey => '-IMPL::SQL::Schema::Constraint::PrimaryKey', + UniqueIndex => '-IMPL::SQL::Schema::Constraint::Unique', + Index => '-IMPL::SQL::Schema::Constraint::Index', + ForeignKey => '-IMPL::SQL::Schema::Constraint::ForeignKey', + CharType => '-IMPL::SQL::Schema::MySQL::CharType', + EnumType => '-IMPL::SQL::Schema::MySQL::EnumType', + TraitsDropTable => '-IMPL::SQL::Schema::Traits::DropTable', + TraitsCreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', + TraitsAlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', + TraitsAlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', + TraitsAlterTableDropColumn => '-IMPL::SQL::Schema::Traits::AlterTableDropColumn', + TraitsAlterTableAddColumn => '-IMPL::SQL::Schema::Traits::AlterTableAddColumn', + TraitsAlterTableChangeColumn => '-IMPL::SQL::Schema::Traits::AlterTableChangeColumn' +}; + +our %TRAITS_FORMATS = ( + TraitsDropTable, 'FormatDropTable', + TraitsCreateTable, 'FormatCreateTable', + TraitsAlterTableDropConstraint, 'FormatAlterTableDropConstraint', + TraitsAlterTableAddConstraint, 'FormatAlterTableAddConstraint', + TraitsAlterTableDropColumn, 'FormatAlterTableDropColumn', + TraitsAlterTableAddColumn, 'FormatAlterTableAddColumn', + TraitsAlterTableChangeColumn, 'FormatAlterTableChangeColumn' +); + +sub quote { + my $self = shift; + + if (wantarray) { + return map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; + } + else { + return join '', map { my $str = $_; $str =~ s/'/''/g; "'$str'"; } @_; + } +} + +sub quote_names { + my $self = shift; + + if (wantarray) { + return map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; + } + else { + return join '', map { my $str = $_; $str =~ s/`/``/g; "`$str`"; } @_; + } +} + +sub formatTypeNameInteger { + my ( $self, $type ) = @_; + + return + $type->name + . ( $type->maxLength ? '(' . $type->maxLength . ')' : '' ) + . ( $type->unsigned ? ' UNSIGNED' : '' ) + . ( $type->zerofill ? ' ZEROFILL' : '' ); +} + +sub formatTypeNameReal { + my ( $self, $type ) = @_; + + return $type->name + . ( $type->maxLength + ? '(' . $type->maxLength . ', ' . $type->scale . ')' + : '' ) + . ( $type->unsigned ? ' UNSIGNED' : '' ) + . ( $type->zerofill ? ' ZEROFILL' : '' ); +} + +sub formatTypeNameNumeric { + my ( $self, $type ) = @_; + $type->maxLength + or die ArgException->new( + type => 'The length and precission must be specified', + $type->name + ); + return $type->name + . ( $type->maxLength + ? '(' . $type->maxLength . ', ' . $type->scale . ')' + : '' ) + . ( $type->unsigned ? ' UNSIGNED' : '' ) + . ( $type->zerofill ? ' ZEROFILL' : '' ); +} + +sub formatTypeName { + my ( $self, $type ) = @_; + return $type->name; +} + +sub formatTypeNameChar { + my ( $self, $type ) = @_; + + return ($type->name . '(' + . $type->MaxLength . ')' + . ( is( $type, CharType ) ? $type->encoding : '' ) ); +} + +sub formatTypeNameVarChar { + my ( $self, $type ) = @_; + + return ($type->name . '(' + . $type->maxLength . ')' + . ( is( $type, CharType ) ? $type->encoding : '' ) ); +} + +sub formatTypeNameEnum { + my ( $self, $type ) = @_; + + die ArgException->new( type => 'Invalid enum type' ) + unless is( $type, EnumType ); + return ($type->name . '(' + . join( ',', map { $self->quote($_) } $type->enumValues ) + . ')' ); +} + +sub formatStringValue { + my ( $self, $value ) = @_; + + if ( ref $value eq 'SCALAR' ) { + return $$value; + } + else { + return $self->quote($value); + } +} + +sub formatNumberValue { + my ( $self, $value ) = @_; + + if ( ref $value eq 'SCALAR' ) { + return $$value; + } + else { + $value =~ /^((\+|-)\s*)?\d+(\.\d+)?(e(\+|-)?\d+)?$/ + or die ArgException->new( + value => 'The specified value isn\'t a valid number', + $value + ); + return $value; + } +} + +our %TYPES_FORMATS = ( + TINYINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + SMALLINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + MEDIUMINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + INT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + INTEGER => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + BIGINT => { + formatType => \&formatTypeNameInteger, + formatValue => \&formatNumberValue + }, + REAL => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + DOUBLE => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + FLOAT => { + formatType => \&formatTypeNameReal, + formatValue => \&formatNumberValue + }, + DECIMAL => { + formatType => \&formatTypeNameNumeric, + formatValue => \&formatNumberValue + }, + NUMERIC => { + formatType => \&formatTypeNameNumeric, + formatValue => \&formatNumberValue + }, + DATE => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TIME => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TIMESTAMP => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + DATETIME => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + CHAR => { + formatType => \&formatTypeNameChar, + formatValue => \&formatStringValue + }, + VARCHAR => { + formatType => \&formatTypeNameVarChar, + formatValue => \&formatStringValue + }, + TINYBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + BLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + MEDIUMBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + LONGBLOB => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TINYTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + TEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + MEDIUMTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + LONGTEXT => { + formatType => \&formatTypeName, + formatValue => \&formatStringValue + }, + ENUM => { + formatType => \&formatTypeNameEnum, + formatValue => \&formatStringValue + }, + SET => { + formatType => \&formatTypeNameEnum, + formatValue => \&formatStringValue + } +); + +sub FormatTypeName { + my ( $self, $type ) = @_; + + my $fn = $TYPES_FORMATS{ $type->name }{formatType} + or die ArgException->new( type => "The specified type is unknown", + $type->name ); + + return $self->$fn($type); +} + +sub FormatValue { + my ( $self, $value, $type ) = @_; + + my $fn = $TYPES_FORMATS{ $type->name }{formatValue} + or die ArgException->new( type => "The specified type is unknown", + $type->name ); + + return $self->$fn( $value, $type ); +} + +sub FormatColumn { + my ( $self, $column ) = @_; + + my @parts = ( + $self->quote_names( $column->{name} ), + $self->FormatTypeName( $column->{type} ), + $column->{isNullable} ? 'NULL' : 'NOT NULL' + ); + + push @parts, $self->FormatValue( $column->{defaultValue}, $column->{type} ) + if $column->{defaultValue}; + + push @parts, 'AUTO_INCREMENT' + if $column->{tag} and $column->{tag}->{auto_increment}; + + return join ' ', @parts; +} + +sub FormatCreateTable { + my ( $self, $op ) = @_; + + my $table = $op->table; + + my @lines; + my @body; + + push @lines, "CREATE TABLE " . $self->quote_names($table->{name}) . "("; + + push @body, map { " " . $self->FormatColumn($_) } @{ $table->{columns} } + if $table->{columns}; + + push @body, map { " " . $self->FormatConstraint($_) } @{ $table->{constraints} } + if $table->{constraints}; + + push @lines, join(",\n", @body); + + push @lines, ");"; + + return join "\n", @lines; +} + +sub FormatDropTable { + my ( $self, $op ) = @_; + + return join ' ', 'DROP TABLE', $self->quote_names( $op->tableName ), ';'; +} + +sub FormatRenameTable { + my ( $self, $op ) = @_; + + return join ' ', + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'RENAME TO', + $self->quote_names( $op->tableNewName ), + ';'; +} + +sub FormatAlterTableAddColumn { + my ( $self, $op, $schema ) = @_; + + my @parts = ( + 'ALTER TABLE',$self->quote_names($op->tableName), 'ADD COLUMN', + $self->FormatColumn( $op->column ) + ); + + if ( defined $op->position ) { + + # mysql supports column reordering + # the new location is specified relative to the previous column + # to determine the name of the previous column we need to ask the schema + + my $table = $schema->GetTable( $op->tableName ); + + if ( $op->position == 0 ) { + push @parts, 'FIRST'; + } + else { + push @parts, 'AFTER'; + + my $prevColumn = $table->GetColumnAt( $op->position - 1 ); + push @parts, $self->quote_names( $prevColumn->{name} ); + } + } + + push @parts, ';'; + + return join ' ', @parts; +} + +sub FormatAlterTableDropColumn { + my ( $self, $op ) = @_; + + return join ' ', + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'DROP COLUMN', + $self->quote_names( $op->columnName ), + ';'; +} + +sub FormatAlterTableChangeColumn { + my ( $self, $op, $schema ) = @_; + + my $table = $schema->GetTable( $op->tableName ); + my $column = $table->GetColumn( $op->columnName ); + + my @parts = ( + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'MODIFY COLUMN', + $self->quote_names( $op->columnName ), + $self->FormatColumn( $self->_Column2Traits($column) ) + ); + + if ( defined $op->position ) { + + # mysql supports column reordering + # the new location is specified relative to the previous column + # to determine the name of the previous column we need to ask the schema + + if ( $op->position == 0 ) { + push @parts, 'FIRST'; + } + else { + push @parts, 'AFTER'; + + my $prevColumn = $table->GetColumnAt( $op->position - 1 ); + push @parts, $self->quote_names( $prevColumn->{name} ); + } + } + + push @parts, ';'; + return join ' ', @parts; +} + +sub FormatConstraint { + my ($self,$constraint) = @_; + + my @fkRules = + ( 'RESTRICT', 'CASCADE', 'SET NULL', 'SET DEFAULT', 'NO ACTION' ); + + my @parts; + + if ( $constraint->constraintClass eq ForeignKey ) { + push @parts, + 'CONSTRAINT', + $self->quote_names( $constraint->{name} ), + 'FOREIGN KEY', + $self->quote_names( $constraint->{name} ), + '(', + join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), + ')', + 'REFERENCES', $self->quote_names( $constraint->{foreignTable} ), '(', + join( ', ', + $self->quote_names( @{ $constraint->{foreignColumns} || [] } ) ), + ')'; + + if ( my $rule = uc( $constraint->{onDelete} ) ) { + grep $_ eq $rule, @fkRules + or die Exception->new( "Invalid onDelete rule specified", + $constraint->{name}, $rule ); + + push @parts, 'ON DELETE', $rule; + } + + if ( my $rule = uc( $constraint->{onUpdate} ) ) { + grep $_ eq $rule, @fkRules + or die Exception->new( "Invalid onUpdate rule specified", + $constraint->{name}, $rule ); + + push @parts, 'ON UPDATE', $rule; + } + + } + else { + if ( $constraint->constraintClass eq PrimaryKey ) { + push @parts, 'PRIMARY KEY'; + + } + elsif ( $constraint->constraintClass eq UniqueIndex ) { + push @parts, 'UNIQUE', $self->quote_names( $constraint->{name} ); + } + elsif ( $constraint->constraintClass eq Index ) { + push @parts, 'INDEX', $self->quote_names( $constraint->{name} ); + } + else { + die Exception->new( 'Invalid constraint type', + $constraint->constraintClass ); + } + + push @parts, + '(', + join( ', ', $self->quote_names( @{ $constraint->{columns} || [] } ) ), + ')'; + } + + + return join ' ', @parts; +} + +sub FormatAlterTableAddConstraint { + my ( $self, $op ) = @_; + + return join(' ', + 'ALTER TABLE', + $self->quote_names( $op->tableName ), + 'ADD', + $self->FormatConstraint($op->constraint), + ';' + ); +} + +sub FormatAlterTableDropConstraint { + my ( $self, $op, $constraintType ) = @_; + + my @parts = ( 'ALTER TABLE', $self->quote_names( $op->tableName ), 'DROP' ); + + if ( $constraintType eq PrimaryKey ) { + push @parts, 'PRIMARY KEY'; + } + elsif ( $constraintType eq ForeignKey ) { + push @parts, 'FOREIGN KEY', $self->quote_names( $op->constraintName ); + } + elsif ( $constraintType eq UniqueIndex or $constraintType eq Index ) { + push @parts, 'INDEX', $self->quote_names( $op->constraintName ); + } + else { + die Exception->new( + 'Invalid constraint type', $op->tableName, + $op->constraintName, $constraintType + ); + } + + push @parts, ';'; + + return join ' ', @parts; +} + +sub Format { + my $self = shift; + my ($op) = @_; + + my $formatter = $TRAITS_FORMATS{ref $op} + or die OpException->new("Don't know how to format the specified operation", $op); + + $self->$formatter(@_); +} + +sub _Column2Traits { + my ( $self, $column, %options ) = @_; + + return new IMPL::SQL::Schema::Traits::Column( + $column->name, + $column->type, + isNullable => $column->isNullable, + defaultValue => $column->defaultValue, + tag => $column->tag, + %options + ); +} + +1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::SQL::Traits::MysqlFormatter> - преобразует операции над схемой в C<SQL> +выражения. + +=head1 DESCRIPTION + +Используется для форматирования операций изменения схемы БД. Осуществляет +правильное экранирование имен, форматирование значений, имен типов данных. + +=cut
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/MySQL/Processor.pm Mon Jan 28 02:43:14 2013 +0400 @@ -0,0 +1,93 @@ +package IMPL::SQL::Schema::MySQL::Processor; +use strict; + +use mro; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + MySQLFormatter => 'IMPL::SQL::Schema::MySQL::Formatter', + AlterTableDropConstraint => '-IMPL::SQL::Schema::Traits::AlterTableDropConstraint', + AlterTableAddConstraint => '-IMPL::SQL::Schema::Traits::AlterTableAddConstraint', + CreateTable => '-IMPL::SQL::Schema::Traits::CreateTable', + Table => '-IMPL::SQL::Schema::Traits::Table', + ForeignKey => '-IMPL::SQL::Schema::Traits::ForeignKey', + + }, + base => [ + 'IMPL::SQL::Schema::Processor' => sub { $_[0] } + ], + props => [ + formatter => PROP_RO, + sqlBatch => PROP_RO + ] +}; +use IMPL::lang qw(is); + +sub CTOR { + my ( $this, $schema, %opts ) = @_; + + $this->formatter( $opts{formatter} || MySQLFormatter ); + $this->sqlBatch([]); +} + +sub AddSqlBatch { + my $this = shift; + + push @{$this->sqlBatch}, @_; +} + +sub ApplyOperation { + my ($this, $op, $iteration ) = @_; + + my @formatterParams; + + if ( is( $op, AlterTableDropConstraint ) ) { + my $constraint = $this + ->dbSchema + ->GetTable($op->tableName) + ->GetConstraint($op->constraintName); + + push @formatterParams, ref $constraint; + } else { + push @formatterParams, $this->dbSchema; + } + + if ( is( $op, CreateTable ) ) { + my @constraints; + my @fk; + my $table = $op->table; + + # отделяем создание внешних ключей от таблиц + + foreach my $c (@{$table->{constraints} || []}) { + if ( is($c,ForeignKey)) { + push @fk,$c; + } else { + push @constraints, $c; + } + } + + if (@fk) { + $op = CreateTable->new( + Table->new( + $table->{name}, + $table->{columns}, + \@constraints, + $table->{options} + ) + ); + + $this->AddPendingOperations( + map AlterTableAddConstraint->new($table->{name},$_), @fk + ); + } + } + + $this->next::method($op,$iteration); + + $this->AddSqlBatch( + $this->formatter->Format($op,@formatterParams) + ); +} + +1;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Lib/IMPL/SQL/Schema/Processor.pm Mon Jan 28 02:43:14 2013 +0400 @@ -0,0 +1,99 @@ +package IMPL::SQL::Schema::Processor; +use strict; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Exception => 'IMPL::Exception', + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + 'IMPL::Object' => undef + ], + props => [ + dbSchema => PROP_RO, + updateBatch => PROP_RO, + pendingOperations => PROP_RO + ] +}; + +sub CTOR { + my ($this,$schema) = @_; + + $this->dbSchema($schema) + or die ArgException->new(schema => 'A DB schema is required'); + + $this->updateBatch([]); + $this->pendingOperations([]); +} + +sub AddUpdateBatch { + my $this = shift; + + push @{$this->updateBatch}, @_; +} + +sub AddPendingOperations { + my $this = shift; + + push @{$this->pendingOperations}, @_; +} + +sub ProcessBatch { + my ($this,$batch) = @_; + + $this->pendingOperations($batch); + my $i = 1; + while(@{$this->pendingOperations}) { + $batch = $this->pendingOperations; + $this->pendingOperations([]); + + my $noChanges = 1; + + foreach my $op (@$batch) { + if ($this->CanApplyOperation($op,$i)) { + $noChanges = 0; + + $this->ApplyOperation($op,$i); + } else { + $this->AddPendingOperations($op); + } + } + + if ($noChanges && @{$this->pendingOperations}) { + die Exception->new("No changes were made (iteration $i), but some operations are pending",@{$this->pendingOperations}); + } + + $i++; + } +} + +sub CanApplyOperation { + my ($this,$op) = @_; + + return $op->CanApply($this->dbSchema); +} + +sub ApplyOperation { + my ($this,$op) = @_; + + $op->Apply($this->dbSchema); + $this->AddUpdateBatch($op); +} + +1; + +__END__ + +=pod + +=head1 NAME + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Позволяет применит набор примитивных операций C<IMPL::SQL::Schema::Traits> к +схеме. + +=cut \ No newline at end of file
--- a/Lib/IMPL/SQL/Schema/Table.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Table.pm Mon Jan 28 02:43:14 2013 +0400 @@ -36,12 +36,6 @@ $this->InsertColumn($_) foreach @{$args{columns}}; } - - if ($args{constraints}) { - die new IMPL::InvalidOperationException('A constraints property should be a reference to an array') unless ref $args{constraints} eq 'ARRAY'; - - $this->AddConstraint($_) foreach @{$args{constraints}}; - } } sub InsertColumn { @@ -181,6 +175,8 @@ $type = IMPL::SQL::Schema::Constraint->ResolveAlias($type) or die new IMPL::Exception("Can't resolve a constraint alias",$_[0]); + $params = {%{$params}}; + $params->{table} = $this; $this->AddConstraint($type->new(%$params));
--- a/Lib/IMPL/SQL/Schema/Traits.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/Lib/IMPL/SQL/Schema/Traits.pm Mon Jan 28 02:43:14 2013 +0400 @@ -114,6 +114,8 @@ use fields qw( foreignTable foreignColumns + onUpdate + onDelete ); use constant { constraintClass => typeof IMPL::SQL::Schema::Constraint::ForeignKey }; @@ -123,10 +125,13 @@ ); sub CTOR { - my ($this,$foreignTable,$foreignColumns) = @_[0,3,4]; + my ($this,$foreignTable,$foreignColumns,%args) = @_[0,3..$#_]; $this->{foreignTable} = $foreignTable; - $this->{foreignColunms} = $foreignColumns; + $this->{foreignColumns} = $foreignColumns; + + $this->{onDelete} = $args{onDelete} if $args{onDelete}; + $this->{onUpdate} = $args{onUpdate} if $args{onUpdate}; } @@ -134,238 +139,398 @@ package IMPL::SQL::Schema::Traits::CreateTable; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Table => '-IMPL::SQL::Schema::Traits::Table', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + table => PROP_RO, + ] +}; 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::Schema::Traits::Table type is required") - unless is $table, typeof IMPL::SQL::Schema::Traits::Table; + die ArgException->new("table", "An object of IMPL::SQL::Schema::Traits::Table type is required") + unless is($table, Table); $this->table($table); } -sub apply { +sub CanApply { my ($this,$schema) = @_; - return 0 if ( $schema->GetTable( $this->table->{name} ) ); + return( $schema->GetTable( $this->table->{name} ) ? 0 : 1 ); +} + +sub Apply { + my ($this,$schema) = @_; - $schema->AddTable($this->table); - return 1; + my $args = {%{$this->table}}; + + my $constraints = delete $args->{constraints} || []; + + my $table = $schema->AddTable($args); + + $table->AddConstraint($_->constraintClass, $_) foreach @{$constraints}; } ################################################## package IMPL::SQL::Schema::Traits::DropTable; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; - -BEGIN { - public property tableName => prop_get | owner_set; -} +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + ] +}; sub CTOR { my ($this,$tableName) = @_; - $this->tableName($tableName) or die new IMPL::InvalidArgumentException("tableName is required"); + $this->tableName($tableName) or die ArgException->new("tableName is required"); } -sub apply { +sub CanApply { my ($this,$schema) = @_; - return 0 if $schema->GetTable( $this->tableName ); + return $schema->GetTable( $this->tableName ) ? 1 : 0; +} + +sub Apply { + my ($this,$schema) = @_; $schema->RemoveTable($this->tableName); - - return 1; } ################################################## package IMPL::SQL::Schema::Traits::RenameTable; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; - -BEGIN { - public property tableName => prop_get | owner_set; - public property tableNewName => prop_get | owner_set; -} +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + ArgException => '-IMPL::InvalidArgumentException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + tableNewName => PROP_RO, + ] +}; 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"); + $this->tableName($oldName) or die ArgException->new("A table name is required"); + $this->tableNewName($newName) or die ArgException->new("A new table name is required"); } -sub apply { +sub CanApply { + my ($this, $schema) = @_; + + return ($schema->GetTable($this->tableName) and not $schema->GetTable($this->tableNewName) ? 1 : 0 ); +} + +sub Apply { my ($this,$schema) = @_; - return 0 if not $schema->GetTable($this->tableName) or $schema->GetTable($this->tableNewName); + $schema->RenameTable($this->tableName, $this->tableNewName); - $this->RenameTable($this->tableName, $this->tableNewName); - - return 1; } ################################################# package IMPL::SQL::Schema::Traits::AlterTableAddColumn; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Column => '-IMPL::SQL::Schema::Traits::Column', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + column => PROP_RO, + position => PROP_RO + ] +}; use IMPL::lang; -BEGIN { - public property tableName => prop_get | owner_set; - public property column => prop_get | owner_set; - public property position => prop_get | owner_set; -} sub CTOR { my ($this,$tableName,$column) = @_; - $this->tableName($tableName) or die new IMPL::InvalidArgumentException("A table name is required"); + $this->tableName($tableName) or die ArgException->new("A table name is required"); - die new IMPL::InvalidArgumentException("A column should be a IMPL::SQL::Schema::Traits::Column object") - unless is $column, typeof IMPL::SQL::Schema::Traits::Column; + die ArgException->new("A column should be a IMPL::SQL::Schema::Traits::Column object") + unless is($column, Column); $this->column($column); } -sub apply { +sub CanApply { my ($this,$schema) = @_; - my $table = $schema->GetTable($this->tableName) or return 0; + my $table = $schema->GetTable($this->tableName) + or return 0; - return 0 if $table->GetColumn( $this->column->{name} ); + return $table->GetColumn( $this->column->{name} ) ? 0 : 1; +} + +sub Apply { + my ($this,$schema) = @_; - $table->AddColumn($this->column); + my $table = $schema->GetTable($this->tableName) + or die OpException->new("The specified table doesn't exists", $this->tableName); - return 1; + if ($this->position) { + $table->AddColumn($this->column); + } else { + $table->InsertColumn($this->column,$this->position); + } } ################################################# package IMPL::SQL::Schema::Traits::AlterTableDropColumn; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; -BEGIN { - public property tableName => prop_get | owner_set; - public property columnName => prop_get | owner_set; -} +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + FK => '-IMPL::SQL::Schema::Constraint::ForeignKey', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + columnName => PROP_RO, + ] +}; +use IMPL::lang; + 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"); + $this->tableName($table) or die ArgException->new(tableName => "A table name should be specified"); + $this->columnName($column) or die ArgException->new(columnName => "A column name should be specified"); } -sub apply { +sub CanApply { my ($this,$schema) = @_; - local $@; + my $table = $schema->GetTable($this->tableName) + or return 0; + + $table->GetColumn($this->columnName) or + return 0; - return eval { - $schema->GetTable($this->tableName)->RemoveColumn($this->columnName); - return 1; - } || 0; + # столбец + return $table->GetColumnConstraints($this->columnName) + ? 0 + : 1 + ; +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die OpException->new("The specified table doesn't exists", $this->tableName); + + $table->RemoveColumn($this->columnName); } ################################################# package IMPL::SQL::Schema::Traits::AlterTableChangeColumn; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; -BEGIN { - public property tableName => prop_get | owner_set; - public property columnName => prop_get | owner_set; - public property columnType => prop_all; - public property defaultValue => prop_all; - public property isNullable => prop_all; - public property position => prop_all; - public property options => prop_all; # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) -} +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Constraint => '-IMPL::SQL::Schema::Traits::Constraint', + ArgException => '-IMPL::InvalidArgumentException', + OpException => '-IMPL::InvalidOperationException' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + columnName => PROP_RO, + columnType => PROP_RW, + defaultValue => PROP_RW, + isNullable => PROP_RW, + position => PROP_RW, + options => PROP_RW # hash diff format, (keys have a prefix '+' - add or update value, '-' remove value) + ] +}; +use IMPL::lang; 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->tableName($table) or die ArgException->new(tableName => "A table name is required"); + $this->columnName($column) or die ArgException->new(columnName => "A column name is required"); $this->$_($args{$_}) for (grep exists $args{$_}, qw(columnType defaultValue isNullable options)); } -sub apply { +sub CanApply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + return $table->GetColumn($this->columnName) ? 1 : 0; +} + +sub Apply { my ($this,$schema) = @_; - local $@; + my $table = $schema->GetTable($this->tableName) + or die OpException->new("The specified table doesn't exists", $this->tableName); + + my $column = $table->GetColumn($this->columnName) + or die OpException->new("The specified column doesn't exists", $this->tableName, $this->columnName); - return eval { - my $column = $schema->GetTable($this->tableName)->GetColumn($this->columnName); - $column->SetType($this->columnType) if defined $this->columnType; - $column->SetNullable($this->isNullable) if defined $this->isNullable; - $column->SetDefaultValue($this->defaultValue) if defined $this->defaultValue; - $column->SetOptions($this->options) if defined $this->options; - - return 1; - } || 0; + $column->SetType($this->columnType) if defined $this->columnType; + $column->SetNullable($this->isNullable) if defined $this->isNullable; + $column->SetDefaultValue($this->defaultValue) if defined $this->defaultValue; + $column->SetOptions($this->options) if defined $this->options; + + $table->SetColumnPosition($this->position) + if ($this->position); + } ################################################# package IMPL::SQL::Schema::Traits::AlterTableAddConstraint; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; + +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + Constraint => '-IMPL::SQL::Schema::Traits::Constraint', + ArgException => '-IMPL::InvalidArgumentException', + FK => '-IMPL::SQL::Schema::Traits::ForeignKey' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + constraint => PROP_RO + ] +}; use IMPL::lang; -BEGIN { - public property tableName => prop_get | owner_set; - public property constraint => prop_get | owner_set; -} - sub CTOR { my ($this,$table,$constraint) = @_; - $this->tableName($table) or die new IMPL::InvalidArgumentException( tableName => "A table name is required"); + $this->tableName($table) or die ArgException->new( tableName => "A table name is required"); - die new IMPL::InvalidArgumentException(constaraint => "A valid IMPL::SQL::Schema::Traits::Constarint is required") - unless is $constraint, typeof IMPL::SQL::Schema::Traits::Constraint; + die ArgException->new(constaraint => "A valid " . Constraint . " is required") + unless is($constraint, Constraint); $this->constraint($constraint); } -sub apply { +sub CanApply { + my ($this, $schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or return 0; + + my $constraint = $this->constraint; + + my @columns = map $table->GetColumn($_), @{$constraint->{columns} || []}; + + # проверяем, что в таблице есть все столбцы для создания ограничения + return 0 if grep not($_), @columns; + + if (is($constraint,FK)) { + warn "FK"; + my $foreignTable = $schema->GetTable($constraint->{foreignTable}) + or return 0; + + warn "Table OK"; + my @foreignColumns = map $foreignTable->GetColumn($_), @{$constraint->{foreignColumns}||[]}; + + # внешняя таблица имеет нужные столбцы + return 0 + if grep not($_), @foreignColumns; + + warn "FK Columns OK"; + + return 0 + if grep not($columns[$_]->type->SameValue($foreignColumns[$_]->type)), (0 .. $#columns); + + warn "FK Columns types OK"; + } + + return 1; +} + +sub Apply { my ($this,$schema) = @_; - local $@; + my $table = $schema->GetTable($this->tableName) + or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); + + my $constraint = $this->constraint; - return eval { - $schema->GetTable($this->tableName)->AddConstraint($this->constraint->constraintClass, $this->constraint); - return 1; - } || 0; + if (is($constraint,FK)) { + my $args = { %$constraint }; + $args->{referencedTable} = $schema->GetTable(delete $args->{foreignTable}); + $args->{referencedColumns} = delete $args->{foreignColumns}; + $table->AddConstraint($constraint->constraintClass, $args); + } else { + $table->AddConstraint($constraint->constraintClass, $constraint); + } } ################################################# package IMPL::SQL::Schema::Traits::AlterTableDropConstraint; -use parent qw(-norequire IMPL::SQL::Schema::Traits); -use IMPL::Class::Property; - -BEGIN { - public property tableName => prop_get | owner_set; - public property constraintName => prop_get | owner_set; -} +use IMPL::Const qw(:prop); +use IMPL::declare { + require => { + PK => '-IMPL::SQL::Schema::Constraint::PrimaryKey' + }, + base => [ + '-IMPL::SQL::Schema::Traits' => undef + ], + props => [ + tableName => PROP_RO, + constraintName => PROP_RO + ] +}; +use IMPL::lang qw(is); sub CTOR { my ($this,$table,$constraint) = @_; @@ -377,15 +542,30 @@ $this->constraintName($constraint); } -sub apply { +sub CanApply { my ($this,$schema) = @_; - my $table = $schema->GetTable($this->tableName) or return 0; + my $table = $schema->GetTable($this->tableName); + + my $constraint = $table->GetConstraint($this->constraintName) + or return 0; - return 0 unless $table->GetConstraint($this->constraintName); + # есть ли внешние ключи на данную таблицу + return ( + is($constraint,PK) + && values( %{$constraint->connectedFK || {}} ) + ? 0 + : 1 + ); +} + +sub Apply { + my ($this,$schema) = @_; + + my $table = $schema->GetTable($this->tableName) + or die IMPL::InvalidOperationException->new("The specified table doesn't exists", $this->tableName); $table->RemoveConstraint($this->constraintName); - return 1; } @@ -413,9 +593,9 @@ Методы обще для всех примитивных операций. -=head3 C<apply($schema)> +=head3 C<CanApply($schema)> -Пытается приминить операцию к указанной схеме. +Определяет возможность применения операции к указанной схеме. Возвращаемое значение: @@ -423,7 +603,7 @@ =item C<true> -Операция успешно применена к схеме. +Операция приминима к схеме. =item C<false> @@ -431,6 +611,10 @@ =back +=head3 C<Apply($schema)> + +Применяет операцию к указанной схеме. + =head2 Primitive operations =head3 C<IMPL::SQL::Schema::Traits::CreateTable>
--- a/Lib/IMPL/SQL/Schema/Traits/MysqlFormatter.pm Fri Jan 25 00:25:02 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -package IMPL::SQL::Schema::Traits::MysqlFormatter; -use strict; - -sub quote{ - my $self = shift; - - if (wantarray) { - return map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/'/''/g; "'$str'"; } @_; - } -} - -sub quote_names { - my $self = shift; - - if (wantarray) { - return map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } else { - return join '',map { my $str=$_; $str=~ s/`/``/g; "`$str`"; } @_; - } -} - -sub FormatTypeName { - my ($self,$type) = @_; - -} - -sub FormatValue { - my ($self,$value,$type) = @_; -} - -sub FormatColumn { - my ($self, $column) = @_; - - my @parts = ( - $self->quote_names($column->{name}), - $self->FormatTypeName($column->{type}), - $column->isNullable ? 'NULL' : 'NOT NULL' - ); - - push @parts, $self->FormatValue( $column->{defaultValue}, $column->{type} ) - if $column->{defaultValue}; - - push @parts, 'AUTO_INCREMENT' - if $column->{tag} and $column->{tag}->{auto_increment}; - - return join ' ', @parts; -} - -sub FormatCreateTable { - my ($self,$op) = @_; - - my $table = $op->table; - - my @lines; - - push @lines, "CREATE TABLE ("; - - push @lines, map { " " . $self->FormatColumn($_) } @{$table->{columns}} - if $table->{columns}; - - push @lines, ");"; - - return join "\n",@lines; -} - -sub FormatDropTable { - my ($self,$op) = @_; - - return join ' ', - 'DROP TABLE', - $self->quote_names($op->{tableName}), - ';'; -} - -sub FormatRenameTable { - my ($self,$op) = @_; - - return join ' ', - 'ALTER TABLE', - $self->quote_names($op->{tableName}), - 'RENAME TO', - $self->quote_names($op->{tableNewName}), - ';'; -} - -sub FormatAlterTableAddColumn { - my ($this,$op,$schema) = @_; - - my @parts; - - $schema->GetTable($op->{tableName}) -} - -1; \ No newline at end of file
--- a/Lib/IMPL/SQL/Schema/Traits/Processor.pm Fri Jan 25 00:25:02 2013 +0400 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,7 +0,0 @@ -package IMPL::SQL::Traits::Processor; -use parent qw(IMPL::SQL::Schema); - -use IMPL::Class::Property; - - -1;
--- a/Lib/IMPL/lang.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/Lib/IMPL/lang.pm Mon Jan 28 02:43:14 2013 +0400 @@ -8,12 +8,13 @@ require IMPL::Class::PropertyInfo; -our @EXPORT = qw(&is); +our @EXPORT = qw(&is &isclass); our %EXPORT_TAGS = ( base => [ qw( &is &clone + &isclass ) ], @@ -62,7 +63,11 @@ use IMPL::Const qw(:all); sub is($$) { - eval { $_[0]->isa( $_[1] ) }; + eval {ref $_[0] and $_[0]->isa( $_[1] ) }; +} + +sub isclass { + eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; } sub virtual($) {
--- a/_test/Test/Class/Template.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/_test/Test/Class/Template.pm Mon Jan 28 02:43:14 2013 +0400 @@ -29,7 +29,7 @@ }; test IsDerivedFromTemplate => sub { - failed "My::Collection should be a subclass of IMPL::Class:Template" unless is('My::Collection','IMPL::Class::Template'); + failed "My::Collection should be a subclass of IMPL::Class:Template" unless isclass('My::Collection','IMPL::Class::Template'); }; test Specialize => sub {
--- a/_test/Test/SQL/Diff.pm Fri Jan 25 00:25:02 2013 +0400 +++ b/_test/Test/SQL/Diff.pm Mon Jan 28 02:43:14 2013 +0400 @@ -1,35 +1,32 @@ package Test::SQL::Diff; use strict; use warnings; -use parent qw(IMPL::Test::Unit); + +use IMPL::declare { + require => { + MySQLProcessor => 'IMPL::SQL::Schema::MySQL::Processor', + SQLSchema => 'IMPL::SQL::Schema', + SQLDiff => 'IMPL::SQL::Schema::Diff' + }, + base => [ + 'IMPL::Test::Unit' => '@_' + ] +}; use IMPL::Test qw(test failed assert); -use IMPL::SQL::Schema(); use IMPL::SQL::Types qw(Integer Varchar Text); -use IMPL::SQL::Schema::Traits::Diff(); use Data::Dumper; -__PACKAGE__->PassThroughArgs; test diff => sub { - my $schemaSrc = new IMPL::SQL::Schema(name => 'simple', version => 1 ); + my $schemaSrc = SQLSchema->new(name => 'simple', version => 1 ); - my $tbl = $schemaSrc->AddTable({ - name => 'User', - columns => [ - { name => 'name', type => Varchar(255) }, - { name => 'description', type => Varchar(255) } - ] - }); - - $tbl->AddConstraint( unique => { name => 'unique_name', columns => ['name'] }); - - my $schemaDst = new IMPL::SQL::Schema(name => 'simple', version => 2 ); + my $schemaDst = SQLSchema->new(name => 'simple', version => 2 ); my $users = $schemaDst->AddTable({ name => 'User', columns => [ - { name => 'id', type => Integer }, + { name => 'id', type => Integer, tag => {auto_increment => 1} }, { name => 'login', type => Varchar(255) }, { name => 'description', type => Text, isNullable => 1 } ] @@ -38,7 +35,25 @@ $users->SetPrimaryKey('id'); $users->AddConstraint( unique => { name => 'unique_login', columns => ['login'] } ); - #warn Dumper(IMPL::SQL::Schema::Traits::Diff->Diff($schemaSrc,$schemaDst)); + my $profile = $schemaDst->AddTable({ + name => 'Profile', + columns => [ + { name => 'id', type => Integer, tag => {auto_increment => 1} }, + { name => 'uid', type => Integer }, + { name => 'data', type => Text } + ] + }); + + $profile->SetPrimaryKey('id'); + $profile->LinkTo($users, 'uid'); + + my $diff = SQLDiff->Diff($schemaSrc,$schemaDst); + + my $processor = MySQLProcessor->new($schemaSrc); + $processor->ProcessBatch($diff); + + warn Dumper($diff); + warn Dumper($processor->sqlBatch); $schemaSrc->Dispose; $schemaDst->Dispose;