lib/SQL/Translator/Generator/DDL/SQLServer.pm

   1 package SQL::Translator::Generator::DDL::SQLServer;
   2
   3 use Moo;
   4 use SQL::Translator::Generator::Utils;
   5 use SQL::Translator::Schema::Constants;
   6
   7 with 'SQL::Translator::Generator::Role::Quote';
   8 with 'SQL::Translator::Generator::Role::DDL';
   9
  10 sub quote_chars { [qw([ ])] }
  11 sub name_sep { q(.) }
  12
  13 sub _build_numeric_types {
  14    +{
  15       int => 1,
  16    }
  17 }
  18
  19 sub _build_unquoted_defaults {
  20    +{
  21       NULL => 1,
  22    }
  23 }
  24
  25 sub _build_type_map {
  26    +{
  27       date => 'datetime',
  28       'time' => 'datetime',
  29    }
  30 }
  31
  32 has sizeless_types => (
  33    is => 'ro',
  34    builder => '_build_sizeless_types',
  35 );
  36
  37 sub _build_sizeless_types {
  38    +{ map { $_ => 1 }
  39          qw( tinyint smallint int integer bigint text bit image datetime ) }
  40 }
  41
  42 sub field {
  43    my ($self, $field) = @_;
  44
  45    return join ' ', $self->field_name($field), ($self->field_type($field)||die 'type is required'),
  46       $self->field_autoinc($field),
  47       $self->field_nullable($field),
  48       $self->field_default($field),
  49 }
  50
  51 sub field_type_size {
  52    my ($self, $field) = @_;
  53
  54    ($field->size && !$self->sizeless_types->{$field->data_type}
  55       ? '(' . $field->size . ')'
  56       : ''
  57    )
  58 }
  59
  60 sub field_autoinc { ( $_[1]->is_auto_increment ? 'IDENTITY' : () ) }
  61
  62 sub primary_key_constraint {
  63   'CONSTRAINT ' .
  64     $_[0]->quote($_[1]->name || $_[1]->table->name . '_pk') .
  65     ' PRIMARY KEY (' .
  66     join( ', ', map $_[0]->quote($_), $_[1]->fields ) .
  67     ')'
  68 }
  69
  70 sub index {
  71   'CREATE INDEX ' .
  72    $_[0]->quote($_[1]->name || $_[1]->table->name . '_idx') .
  73    ' ON ' . $_[0]->quote($_[1]->table->name) .
  74    ' (' . join( ', ', map $_[0]->quote($_), $_[1]->fields ) . ');'
  75 }
  76
  77 sub unique_constraint_single {
  78   my ($self, $constraint) = @_;
  79
  80   'CONSTRAINT ' .
  81    $self->unique_constraint_name($constraint) .
  82    ' UNIQUE (' . join( ', ', map $self->quote($_), $constraint->fields ) . ')'
  83 }
  84
  85 sub unique_constraint_name {
  86   my ($self, $constraint) = @_;
  87   $self->quote($constraint->name || $constraint->table->name . '_uc' )
  88 }
  89
  90 sub unique_constraint_multiple {
  91   my ($self, $constraint) = @_;
  92
  93   'CREATE UNIQUE NONCLUSTERED INDEX ' .
  94    $self->unique_constraint_name($constraint) .
  95    ' ON ' . $self->quote($constraint->table->name) . ' (' .
  96    join( ', ', $constraint->fields ) . ')' .
  97    ' WHERE ' . join( ' AND ',
  98     map $self->quote($_->name) . ' IS NOT NULL',
  99     grep { $_->is_nullable } $constraint->fields ) . ';'
 100 }
 101
 102 sub foreign_key_constraint {
 103   my ($self, $constraint) = @_;
 104
 105   my $on_delete = uc ($constraint->on_delete || '');
 106   my $on_update = uc ($constraint->on_update || '');
 107
 108   # The default implicit constraint action in MSSQL is RESTRICT
 109   # but you can not specify it explicitly. Go figure :)
 110   for (map uc $_ || '', $on_delete, $on_update) {
 111     undef $_ if $_ eq 'RESTRICT'
 112   }
 113
 114   'ALTER TABLE ' . $self->quote($constraint->table->name) .
 115    ' ADD CONSTRAINT ' .
 116    $self->quote($constraint->name || $constraint->table->name . '_fk') .
 117    ' FOREIGN KEY' .
 118    ' (' . join( ', ', map $self->quote($_), $constraint->fields ) . ') REFERENCES '.
 119    $self->quote($constraint->reference_table) .
 120    ' (' . join( ', ', map $self->quote($_), $constraint->reference_fields ) . ')'
 121    . (
 122      $on_delete && $on_delete ne "NO ACTION"
 123        ? ' ON DELETE ' . $on_delete
 124        : ''
 125    ) . (
 126      $on_update && $on_update ne "NO ACTION"
 127        ? ' ON UPDATE ' . $on_update
 128        : ''
 129    ) . ';';
 130 }
 131
 132 sub enum_constraint_name {
 133   my ($self, $field_name) = @_;
 134   $self->quote($field_name . '_chk' )
 135 }
 136
 137 sub enum_constraint {
 138   my ( $self, $field_name, $vals ) = @_;
 139
 140   return (
 141      'CONSTRAINT ' . $self->enum_constraint_name($field_name) .
 142        ' CHECK (' . $self->quote($field_name) .
 143        ' IN (' . join( ',', map qq('$_'), @$vals ) . '))'
 144   )
 145 }
 146
 147 sub constraints {
 148   my ($self, $table) = @_;
 149
 150   (map $self->enum_constraint($_->name, { $_->extra }->{list} || []),
 151      grep { 'enum' eq lc $_->data_type } $table->get_fields),
 152
 153   (map $self->primary_key_constraint($_),
 154      grep { $_->type eq PRIMARY_KEY } $table->get_constraints),
 155
 156   (map $self->unique_constraint_single($_),
 157      grep {
 158        $_->type eq UNIQUE &&
 159        !grep { $_->is_nullable } $_->fields
 160      } $table->get_constraints),
 161 }
 162
 163 sub table {
 164    my ($self, $table) = @_;
 165    join ( "\n", $self->table_comments($table), '' ) .
 166    join ( "\n\n",
 167       'CREATE TABLE ' . $self->quote($table->name) . " (\n".
 168         join( ",\n",
 169            map { "  $_" }
 170            $self->fields($table),
 171            $self->constraints($table),
 172         ) .
 173         "\n);",
 174         $self->unique_constraints_multiple($table),
 175         $self->indices($table),
 176    )
 177 }
 178
 179 sub unique_constraints_multiple {
 180   my ($self, $table) = @_;
 181   (map $self->unique_constraint_multiple($_),
 182      grep {
 183         $_->type eq UNIQUE &&
 184         grep { $_->is_nullable } $_->fields
 185      } $table->get_constraints)
 186 }
 187
 188 sub drop_table {
 189    my ($self, $table) = @_;
 190    my $name = $table->name;
 191    my $q_name = $self->quote($name);
 192    "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" .
 193       " DROP TABLE $q_name;"
 194 }
 195
 196 sub remove_table_constraints {
 197    my ($self, $table) = @_;
 198    my $name = $table->name;
 199    my $q_name = $self->quote($name);
 200    "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" .
 201    " ALTER TABLE $q_name NOCHECK CONSTRAINT all;"
 202 }
 203
 204 sub drop_tables {
 205    my ($self, $schema) = shift;
 206
 207    if ($self->add_drop_table) {
 208       my @tables = sort { $b->order <=> $a->order } $schema->get_tables;
 209       return join "\n", (
 210          ( $self->add_comments ? (
 211          '--',
 212          '-- Turn off constraints',
 213          '--',
 214          '',
 215          ) : () ),
 216          (map $self->remove_table_constraints($_), @tables),
 217          ( $self->add_comments ? (
 218          '--',
 219          '-- Drop tables',
 220          '--',
 221          '',
 222          ) : () ),
 223          (map $self->drop_table($_), @tables),
 224       )
 225    }
 226    return '';
 227 }
 228
 229 sub foreign_key_constraints {
 230    my ($self, $schema) = @_;
 231    ( map $self->foreign_key_constraint($_),
 232      grep { $_->type eq FOREIGN_KEY }
 233      map $_->get_constraints,
 234      $schema->get_tables )
 235 }
 236
 237 sub schema {
 238    my ($self, $schema) = @_;
 239
 240    $self->header_comments .
 241       $self->drop_tables($schema) .
 242       join("\n\n", map $self->table($_), grep { $_->name } $schema->get_tables) .
 243       "\n" . join "\n", $self->foreign_key_constraints($schema)
 244 }
 245
 246 1;
 247