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