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