File Coverage

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

Criterion	Covered	Total	%
statement	65	68	95.5
branch	13	18	72.2
condition	12	28	42.8
subroutine	24	26	92.3
pod	0	20	0.0
total	114	160	71.2

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