JezK
Edit File: SQLServer.pm
package SQL::Translator::Generator::DDL::SQLServer; =head1 NAME SQL::Translator::Generator::DDL::SQLServer - A Moo based MS SQL Server DDL generation engine. =head1 DESCRIPTION I<documentation volunteers needed> =cut use Moo; use SQL::Translator::Schema::Constants; with 'SQL::Translator::Generator::Role::Quote'; with 'SQL::Translator::Generator::Role::DDL'; sub quote_chars { [qw([ ])] } sub name_sep { q(.) } sub _build_numeric_types { +{ int => 1, } } sub _build_unquoted_defaults { +{ NULL => 1, } } sub _build_type_map { +{ date => 'datetime', 'time' => 'datetime', } } sub _build_sizeless_types { +{ map { $_ => 1 } qw( tinyint smallint int integer bigint text bit image datetime ) } } sub field { my ($self, $field) = @_; return join ' ', $self->field_name($field), ($self->field_type($field)||die 'type is required'), $self->field_autoinc($field), $self->field_nullable($field), $self->field_default($field), } sub field_autoinc { ( $_[1]->is_auto_increment ? 'IDENTITY' : () ) } sub primary_key_constraint { 'CONSTRAINT ' . $_[0]->quote($_[1]->name || $_[1]->table->name . '_pk') . ' PRIMARY KEY (' . join( ', ', map $_[0]->quote($_), $_[1]->fields ) . ')' } sub index { 'CREATE INDEX ' . $_[0]->quote($_[1]->name || $_[1]->table->name . '_idx') . ' ON ' . $_[0]->quote($_[1]->table->name) . ' (' . join( ', ', map $_[0]->quote($_), $_[1]->fields ) . ');' } sub unique_constraint_single { my ($self, $constraint) = @_; 'CONSTRAINT ' . $self->unique_constraint_name($constraint) . ' UNIQUE (' . join( ', ', map $self->quote($_), $constraint->fields ) . ')' } sub unique_constraint_name { my ($self, $constraint) = @_; $self->quote($constraint->name || $constraint->table->name . '_uc' ) } sub unique_constraint_multiple { my ($self, $constraint) = @_; 'CREATE UNIQUE NONCLUSTERED INDEX ' . $self->unique_constraint_name($constraint) . ' ON ' . $self->quote($constraint->table->name) . ' (' . join( ', ', map $self->quote($_), $constraint->fields ) . ')' . ' WHERE ' . join( ' AND ', map $self->quote($_->name) . ' IS NOT NULL', grep { $_->is_nullable } $constraint->fields ) . ';' } sub foreign_key_constraint { my ($self, $constraint) = @_; my $on_delete = uc ($constraint->on_delete || ''); my $on_update = uc ($constraint->on_update || ''); # The default implicit constraint action in MSSQL is RESTRICT # but you can not specify it explicitly. Go figure :) for (map uc $_ || '', $on_delete, $on_update) { undef $_ if $_ eq 'RESTRICT' } 'ALTER TABLE ' . $self->quote($constraint->table->name) . ' ADD CONSTRAINT ' . $self->quote($constraint->name || $constraint->table->name . '_fk') . ' FOREIGN KEY' . ' (' . join( ', ', map $self->quote($_), $constraint->fields ) . ') REFERENCES '. $self->quote($constraint->reference_table) . ' (' . join( ', ', map $self->quote($_), $constraint->reference_fields ) . ')' . ( $on_delete && $on_delete ne "NO ACTION" ? ' ON DELETE ' . $on_delete : '' ) . ( $on_update && $on_update ne "NO ACTION" ? ' ON UPDATE ' . $on_update : '' ) . ';'; } sub enum_constraint_name { my ($self, $field_name) = @_; $self->quote($field_name . '_chk' ) } sub enum_constraint { my ( $self, $field_name, $vals ) = @_; return ( 'CONSTRAINT ' . $self->enum_constraint_name($field_name) . ' CHECK (' . $self->quote($field_name) . ' IN (' . join( ',', map $self->quote_string($_), @$vals ) . '))' ) } sub constraints { my ($self, $table) = @_; (map $self->enum_constraint($_->name, { $_->extra }->{list} || []), grep { 'enum' eq lc $_->data_type } $table->get_fields), (map $self->primary_key_constraint($_), grep { $_->type eq PRIMARY_KEY } $table->get_constraints), (map $self->unique_constraint_single($_), grep { $_->type eq UNIQUE && !grep { $_->is_nullable } $_->fields } $table->get_constraints), } sub table { my ($self, $table) = @_; join ( "\n", $self->table_comments($table), '' ) . join ( "\n\n", 'CREATE TABLE ' . $self->quote($table->name) . " (\n". join( ",\n", map { " $_" } $self->fields($table), $self->constraints($table), ) . "\n);", $self->unique_constraints_multiple($table), $self->indices($table), ) } sub unique_constraints_multiple { my ($self, $table) = @_; (map $self->unique_constraint_multiple($_), grep { $_->type eq UNIQUE && grep { $_->is_nullable } $_->fields } $table->get_constraints) } sub drop_table { my ($self, $table) = @_; my $name = $table->name; my $q_name = $self->quote($name); "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" . " DROP TABLE $q_name;" } sub remove_table_constraints { my ($self, $table) = @_; my $name = $table->name; my $q_name = $self->quote($name); "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" . " ALTER TABLE $q_name NOCHECK CONSTRAINT all;" } sub drop_tables { my ($self, $schema) = @_; if ($self->add_drop_table) { my @tables = sort { $b->order <=> $a->order } $schema->get_tables; return join "\n", ( ( $self->add_comments ? ( '--', '-- Turn off constraints', '--', '', ) : () ), (map $self->remove_table_constraints($_), @tables), ( $self->add_comments ? ( '--', '-- Drop tables', '--', '', ) : () ), (map $self->drop_table($_), @tables), ) } return ''; } sub foreign_key_constraints { my ($self, $schema) = @_; ( map $self->foreign_key_constraint($_), grep { $_->type eq FOREIGN_KEY } map $_->get_constraints, $schema->get_tables ) } sub schema { my ($self, $schema) = @_; $self->header_comments . $self->drop_tables($schema) . join("\n\n", map $self->table($_), grep { $_->name } $schema->get_tables) . "\n" . join "\n", $self->foreign_key_constraints($schema) } 1; =head1 AUTHORS See the included AUTHORS file: L<http://search.cpan.org/dist/SQL-Translator/AUTHORS> =head1 COPYRIGHT Copyright (c) 2012 the SQL::Translator L</AUTHORS> as listed above. =head1 LICENSE This code is free software and may be distributed under the same terms as Perl itself. =cut