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