File Coverage

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

Criterion	Covered	Total	%
statement	64	68	94.1
branch	12	18	66.6
condition	12	28	42.8
subroutine	24	26	92.3
pod	0	20	0.0
total	112	160	70.0

package SQL::Translator::Generator::DDL::SQLServer;

=head1 NAME

SQL::Translator::Generator::DDL::SQLServer - A Moo based MS SQL Server DDL
generation engine.

=head1 DESCRIPTION

I

=cut

use Moo;
use SQL::Translator::Schema::Constants;

with 'SQL::Translator::Generator::Role::Quote';
with 'SQL::Translator::Generator::Role::DDL';

sub quote_chars { [qw([ ])] }
sub name_sep { q(.) }

sub _build_numeric_types {
   +{
      int => 1,
   }
}

sub _build_unquoted_defaults {
   +{
      NULL => 1,
   }
}

sub _build_type_map {
   +{
      date => 'datetime',
      'time' => 'datetime',
   }
}

sub _build_sizeless_types {
   +{ map { $_ => 1 }
         qw( tinyint smallint int integer bigint text bit image datetime ) }
}

sub field {
   my ($self, $field) = @_;

   return join ' ', $self->field_name($field), ($self->field_type($field)||die 'type is required'),
      $self->field_autoinc($field),
      $self->field_nullable($field),
      $self->field_default($field),
}

sub field_autoinc { ( $_[1]->is_auto_increment ? 'IDENTITY' : () ) }

sub primary_key_constraint {
  'CONSTRAINT ' .
    $_[0]->quote($_[1]->name || $_[1]->table->name . '_pk') .
    ' PRIMARY KEY (' .
    join( ', ', map $_[0]->quote($_), $_[1]->fields ) .
    ')'
}

sub index {
  'CREATE INDEX ' .
   $_[0]->quote($_[1]->name || $_[1]->table->name . '_idx') .
   ' ON ' . $_[0]->quote($_[1]->table->name) .
   ' (' . join( ', ', map $_[0]->quote($_), $_[1]->fields ) . ');'
}

sub unique_constraint_single {
  my ($self, $constraint) = @_;

  'CONSTRAINT ' .
   $self->unique_constraint_name($constraint) .
   ' UNIQUE (' . join( ', ', map $self->quote($_), $constraint->fields ) . ')'
}

sub unique_constraint_name {
  my ($self, $constraint) = @_;
  $self->quote($constraint->name || $constraint->table->name . '_uc' )
}

sub unique_constraint_multiple {
  my ($self, $constraint) = @_;

  'CREATE UNIQUE NONCLUSTERED INDEX ' .
   $self->unique_constraint_name($constraint) .
   ' ON ' . $self->quote($constraint->table->name) . ' (' .
   join( ', ', map $self->quote($_), $constraint->fields ) . ')' .
   ' WHERE ' . join( ' AND ',
    map $self->quote($_->name) . ' IS NOT NULL',
    grep { $_->is_nullable } $constraint->fields ) . ';'
}

sub foreign_key_constraint {
  my ($self, $constraint) = @_;

  my $on_delete = uc ($constraint->on_delete || '');
  my $on_update = uc ($constraint->on_update || '');

  # The default implicit constraint action in MSSQL is RESTRICT
  # but you can not specify it explicitly. Go figure :)
  for (map uc $_ || '', $on_delete, $on_update) {
    undef $_ if $_ eq 'RESTRICT'
  }

  'ALTER TABLE ' . $self->quote($constraint->table->name) .
   ' ADD CONSTRAINT ' .
   $self->quote($constraint->name || $constraint->table->name . '_fk') .
   ' FOREIGN KEY' .
   ' (' . join( ', ', map $self->quote($_), $constraint->fields ) . ') REFERENCES '.
   $self->quote($constraint->reference_table) .
   ' (' . join( ', ', map $self->quote($_), $constraint->reference_fields ) . ')'
   . (
     $on_delete && $on_delete ne "NO ACTION"
       ? ' ON DELETE ' . $on_delete
       : ''
   ) . (
     $on_update && $on_update ne "NO ACTION"
       ? ' ON UPDATE ' . $on_update
       : ''
   ) . ';';
}

sub enum_constraint_name {
  my ($self, $field_name) = @_;
  $self->quote($field_name . '_chk' )
}

sub enum_constraint {
  my ( $self, $field_name, $vals ) = @_;

  return (
     'CONSTRAINT ' . $self->enum_constraint_name($field_name) .
       ' CHECK (' . $self->quote($field_name) .
       ' IN (' . join( ',', map $self->quote_string($_), @$vals ) . '))'
  )
}

sub constraints {
  my ($self, $table) = @_;

  (map $self->enum_constraint($_->name, { $_->extra }->{list} || []),
     grep { 'enum' eq lc $_->data_type } $table->get_fields),

  (map $self->primary_key_constraint($_),
     grep { $_->type eq PRIMARY_KEY } $table->get_constraints),

  (map $self->unique_constraint_single($_),
     grep {
       $_->type eq UNIQUE &&
       !grep { $_->is_nullable } $_->fields
     } $table->get_constraints),
}

sub table {
   my ($self, $table) = @_;
   join ( "\n", $self->table_comments($table), '' ) .
   join ( "\n\n",
      'CREATE TABLE ' . $self->quote($table->name) . " (\n".
        join( ",\n",
           map { "  $_" }
           $self->fields($table),
           $self->constraints($table),
        ) .
        "\n);",
        $self->unique_constraints_multiple($table),
        $self->indices($table),
   )
}

sub unique_constraints_multiple {
  my ($self, $table) = @_;
  (map $self->unique_constraint_multiple($_),
     grep {
        $_->type eq UNIQUE &&
        grep { $_->is_nullable } $_->fields
     } $table->get_constraints)
}

sub drop_table {
   my ($self, $table) = @_;
   my $name = $table->name;
   my $q_name = $self->quote($name);
   "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" .
      " DROP TABLE $q_name;"
}

sub remove_table_constraints {
   my ($self, $table) = @_;
   my $name = $table->name;
   my $q_name = $self->quote($name);
   "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U')" .
   " ALTER TABLE $q_name NOCHECK CONSTRAINT all;"
}

sub drop_tables {
   my ($self, $schema) = @_;

   if ($self->add_drop_table) {
      my @tables = sort { $b->order <=> $a->order } $schema->get_tables;
      return join "\n", (
         ( $self->add_comments ? (
         '--',
         '-- Turn off constraints',
         '--',
         '',
         ) : () ),
         (map $self->remove_table_constraints($_), @tables),
         ( $self->add_comments ? (
         '--',
         '-- Drop tables',
         '--',
         '',
         ) : () ),
         (map $self->drop_table($_), @tables),
      )
   }
   return '';
}

sub foreign_key_constraints {
   my ($self, $schema) = @_;
   ( map $self->foreign_key_constraint($_),
     grep { $_->type eq FOREIGN_KEY }
     map $_->get_constraints,
     $schema->get_tables )
}

sub schema {
   my ($self, $schema) = @_;

   $self->header_comments .
      $self->drop_tables($schema) .
      join("\n\n", map $self->table($_), grep { $_->name } $schema->get_tables) .
      "\n" . join "\n", $self->foreign_key_constraints($schema)
}

1;

=head1 AUTHORS

See the included AUTHORS file:
L

=head1 COPYRIGHT

Copyright (c) 2012 the SQL::Translator L as listed above.

=head1 LICENSE

This code is free software and may be distributed under the same terms as Perl
itself.

=cut