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

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