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