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

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