[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / SQLServer.pm

package SQL::Translator::Producer::SQLServer;

# -------------------------------------------------------------------
# Copyright (C) 2002-2009 SQLFairy Authors
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator

=head1 SYNOPSIS

  use SQL::Translator;

  my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
  $t->translate;

=head1 DESCRIPTION

B<WARNING>B This is still fairly early code, basically a hacked version of the
Sybase Producer (thanks Sam, Paul and Ken for doing the real work ;-)

=head1 Extra Attributes

=over 4

=item field.list

List of values for an enum field.

=back

=head1 TODO

 * !! Write some tests !!
 * Reserved words list needs updating to SQLServer.
 * Triggers, Procedures and Views DO NOT WORK

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = '1.59';
$DEBUG = 1 unless defined $DEBUG;

use Data::Dumper;
use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(debug header_comment);
use SQL::Translator::ProducerUtils;

my $util = SQL::Translator::ProducerUtils->new( quote_chars => ['[', ']'] );

my %translate  = (
    date       => 'datetime',
    'time'     => 'datetime',
    enum       => 'varchar',
    bytea      => 'varbinary',
    blob       => 'varbinary',
    clob       => 'varbinary',
    tinyblob   => 'varbinary',
    mediumblob => 'varbinary',
    longblob   => 'varbinary',
    text       => 'varchar', # 'Text' datatype is deprecated in favor of 'varchar(max)'
    tinytext   => 'varchar',
    mediumtext => 'varchar',
    longtext   => 'varchar',
);

# If these datatypes have size appended the sql fails.
my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;

my $max_id_length    = 128;
my %global_names;

=pod

=head1 SQLServer Create Table Syntax

TODO

=cut

# -------------------------------------------------------------------
sub produce {
    my $translator     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;
    my $options= {
        add_drop_table    => $add_drop_table,
        show_warnings     => $WARN,
        no_comments       => $no_comments,
    };

    %global_names = (); #reset

    my $output;
    $output .= header_comment."\n" unless ($no_comments);

    # Generate the DROP statements.
    if ($add_drop_table) {
        my @tables = sort { $b->order <=> $a->order } $schema->get_tables;
        $output .= "--\n-- Turn off constraints\n--\n\n" unless $no_comments;
        foreach my $table (@tables) {
            my $name = $table->name;
            my $q_name = $util->quote( $name );
            $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') ALTER TABLE $q_name NOCHECK CONSTRAINT all;\n"
        }
        $output .= "\n";
        $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
        foreach my $table (@tables) {
            my $name = $table->name;
            my $q_name = $util->quote( $name );
            $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $q_name;\n"
        }
    }

    # Generate the CREATE sql

    my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet

    for my $table ( $schema->get_tables ) {
        my $table_name   = $table->name or next;
        my $table_name_q = $util->quote( $table_name );

        my ( @comments, @field_defs, @index_defs, @constraint_defs );

        push @comments, "\n\n--\n-- Table: $table_name_q\n--"
        unless $no_comments;

        push @comments, map { "-- $_" } $table->comments;

        #
        # Fields
        #
        for my $field ( $table->get_fields ) {
            my $field_clause= build_field_clause($field, $options);
            if (lc($field->data_type) eq 'enum') {
                push @constraint_defs, build_enum_constraint($field, $options);
            }
            push @field_defs, $field_clause;
        }

        #
        # Constraint Declarations
        #
        my @constraint_defs = ();
        for my $constraint ( $table->get_constraints ) {
            next unless $constraint->fields;
            my ($stmt, $createClause)= build_constraint_stmt($constraint, $options);
            # use a clause, if the constraint can be written that way
            if ($createClause) {
                push @constraint_defs, $createClause;
            }
            # created a foreign key statement, which we save til the end
            elsif ( $constraint->type eq FOREIGN_KEY ) {
                push @foreign_constraints, $stmt;
            }
            # created an index statement, instead of a clause, which we append to "create table"
            else { #if ( $constraint->type eq UNIQUE ) {
                push @index_defs, $stmt;
            }
        }

        #
        # Indices
        #
        for my $index ( $table->get_indices ) {
            my $idx_name = $index->name || unique_name($table_name . '_idx');
            my $idx_name_q = $util->quote($idx_name);
            push @index_defs,
                "CREATE INDEX $idx_name_q ON $table_name_q (".
                join( ', ', map { $util->quote($_) } $index->fields ) . ");";
        }

        my $create_statement = "";
        $create_statement .= "CREATE TABLE $table_name_q (\n".
            join( ",\n",
                map { "  $_" } @field_defs, @constraint_defs
            ).
            "\n);"
        ;

        $output .= join( "\n\n",
            @comments,
            $create_statement,
            @index_defs,
        );
    }

# Add FK constraints
    $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;

# create view/procedure are NOT prepended to the input $sql, needs
# to be filled in with the proper syntax

=pod

    # Text of view is already a 'create view' statement so no need to
    # be fancy
    foreach ( $schema->get_views ) {
        my $name = $_->name();
        $output .= "\n\n";
        $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
        my $text = $_->sql();
        $text =~ s/\r//g;
        $output .= "$text\nGO\n";
    }

    # Text of procedure already has the 'create procedure' stuff
    # so there is no need to do anything fancy. However, we should
    # think about doing fancy stuff with granting permissions and
    # so on.
    foreach ( $schema->get_procedures ) {
        my $name = $_->name();
        $output .= "\n\n";
        $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
        my $text = $_->sql();
      $text =~ s/\r//g;
        $output .= "$text\nGO\n";
    }
=cut

    return $output;
}

sub alter_field {
    my ($from_field, $to_field, $options) = @_;

    my $field_clause= build_field_clause($to_field, $options);
    my $table_name_q= $util->quote($to_field->table->name);
    
    my @sql;
    if (lc($from_field->data_type) eq 'enum') {
        push @sql, build_drop_enum_constraint($from_field, $options).';';
    }

    push @sql, "ALTER TABLE $table_name_q ALTER COLUMN $field_clause;";

    if ($from_field->name ne $to_field->name) {
        push @sql, rename_field(@_);
    }
    
    if (lc($to_field->data_type) eq 'enum') {
        push @sql, build_add_enum_constraint($to_field, $options).';';
    }
    
    return join("\n", @sql);
}

sub build_rename_field {
    my ($from_field, $to_field, $options) = @_;
 
    return sprintf "EXEC sp_rename \@objname = '%s', \@newname = '%s', \@objtype = 'COLUMN';",
           $from_field->name,
           $to_field->name;
}

sub add_field {
    my ($new_field, $options) = @_;
    
    my $field_clause= build_field_clause(@_);
    my $table_name_q= $util->quote($new_field->table->name);

    my @sql= "ALTER TABLE $table_name_q ADD COLUMN $field_clause;";
    if (lc($new_field->data_type) eq 'enum') {
        push @sql, build_add_enum_constraint($new_field, $options).';';
    }

    return join("\n", @sql);
}

sub drop_field { 
    my ($old_field, $options) = @_;

    my $table_name_q= $util->quote($old_field->table->name);
    my $field_name_q= $util->quote($old_field->name);
    
    my @sql;
    if (lc($old_field->data_type) eq 'enum') {
        push @sql, build_drop_enum_constraint($old_field, $options).';';
    }

    push @sql, "ALTER TABLE $table_name_q DROP COLUMN $field_name_q;";

    return join("\n", @sql);
}

sub alter_create_constraint {
    my ($constraint, $options) = @_;
    my ($stmt, $clause)= build_constraint_stmt(@_);
    return $stmt.';';
}

sub alter_drop_constraint {
    my ($constraint, $options) = @_;
    my $table_name_q= $util->quote($constraint->table->name);
    my $ct_name_q= $util->quote($constraint->name);
    return "ALTER TABLE $table_name_q DROP CONSTRAINT $ct_name_q;";
}

sub alter_create_index {
    my ($index, $options) = @_;
    my ($stmt, $clause)= build_index_stmt(@_);
    return $stmt.';';
}

sub alter_drop_index {
    my ($index, $options) = @_;
    my $table_name_q= $util->quote($index->table->name);
    my $index_name_q= $util->quote($index->name);
    return "ALTER TABLE $table_name_q DROP $index_name_q;";
}

sub drop_table {
    my ($table, $options) = @_;
    my $table_name_q= $util->quote($table->name);
    return "DROP TABLE $table_name_q;";
}

sub build_field_clause {
    my ($field, $options)= @_;
    
    my $field_name   = $field->name;
    my $field_name_q = $util->quote($field_name);
    my $field_def    = $field_name_q;

    #
    # Datatype
    #
    my $data_type      = lc $field->data_type;
    my $orig_data_type = $data_type;
    my %extra          = $field->extra;
    my $list           = $extra{'list'} || [];
    # \todo deal with embedded quotes
    my $commalist      = join( ', ', map { qq['$_'] } @$list );
    my $size           = $field->size;

    if ( $data_type eq 'set' ) {
        # TODO: do we need more logic here?
        $data_type = 'varchar';
    }
    elsif ( defined $translate{ $data_type } ) {
        $data_type = $translate{ $data_type };
    }
    else {
        warn "Unknown datatype: $data_type ",
            "(".$field->table->name.".$field_name)\n" if $WARN;
    }

    if ( grep $_ eq $data_type, @no_size) {
    # SQLServer doesn't seem to like sizes on some datatypes
        $size = undef;
    }
    elsif ( $data_type eq 'varbinary' || $data_type eq 'varchar' ) {
        # SQL Server has a max specifyable size of 8000, but if you say 'max', you get 2^31.  Go figure.
        # Note that 'max' was introduced in SQL Server 2005.  Before that, you need a type of 'image'
        #   or 'text', which is now deprecated.
        # TODO: add server-version support and return 'image'/'text' for older versions than 2005
        if ($orig_data_type =~ /blob|text/) {
            # mysql tinytext and tinyblob have size of 255, which is our default, below
            # else we need 'max'
            $size ||= 'max' unless $orig_data_type =~ /tiny/;
        }
        $size ||= 255;
        # SQL Server barfs on any number greater than 8000, so switch these to 'max'
        $size= 'max' if ($size =~ /[0-9]+/) && $size > 8000;
    }
    elsif ( !$size ) {
        if ( $data_type =~ /numeric/ ) {
            $size = '9,0';
        }
        elsif (
            $data_type eq 'varchar' &&
            $orig_data_type eq 'boolean'
        ) {
            $size = '6';
        }
        elsif ( $data_type eq 'varchar' ) {
            $size = '255';
        }
    }

    $field_def .= " $data_type";
    $field_def .= "($size)" if $size;

    $field_def .= ' IDENTITY' if $field->is_auto_increment;

    #
    # Not null constraint
    #
    unless ( $field->is_nullable ) {
        $field_def .= ' NOT NULL';
    }
    else {
        $field_def .= ' NULL' if $data_type ne 'bit';
    }

    #
    # Default value
    #
    SQL::Translator::Producer->_apply_default_value(
      $field,
      \$field_def,
      [
        'NULL'       => \'NULL',
      ],
    );
    
    return $field_def;
}

sub build_enum_constraint {
    my ($field, $options)= @_;
    my %extra = $field->extra;
    my $list = $extra{'list'} || [];
    # \todo deal with embedded quotes
    my $commalist = join( ', ', map { qq['$_'] } @$list );
    my $field_name_q = $util->quote($field->name);
    my $check_name_q = $util->quote( unique_name( $field->table->name . '_' . $field->name . '_chk' ) );
    return "CONSTRAINT $check_name_q CHECK ($field_name_q IN ($commalist))";
}

sub build_add_enum_constraint {
    my ($field, $options)= @_;
    my $table_name_q = $util->quote($field->table->name);
    return "ALTER TABLE $table_name_q ADD ".build_enum_constraint(@_);
}

sub build_drop_enum_constraint {
    my ($field, $options)= @_;
    my $table_name_q = $util->quote($field->table->name);
    my $check_name_q = $util->quote( unique_name( $field->table->name . '_' . $field->name . '_chk' ) );
    return "ALTER TABLE $table_name_q DROP $check_name_q";
}

# build_constraint_stmt($constraint, $options)
# Returns ($stmt, $clause)
#
# Multiple return values are necessary because some things that you would
#   like to be clauses in CREATE TABLE become separate statements.
# $stmt will always be returned, but $clause might be undef
#
sub build_constraint_stmt {
    my ($constraint, $options)= @_;
    my $table_name_q = $util->quote($constraint->table->name);
    my $field_list   = join(', ', map { $util->quote($_) } $constraint->fields );
    my $type         = $constraint->type || NORMAL;

    if ( $type eq FOREIGN_KEY ) {
        my $ct_name= $constraint->name || unique_name( $constraint->table->name . '_fk' );
        my $ct_name_q=    $util->quote($ct_name);
        my $ref_tbl_q=    $util->quote($constraint->reference_table);
        my $rfield_list=  join( ', ', map { $util->quote($_) } $constraint->reference_fields );

        my $c_def =
            "ALTER TABLE $table_name_q ADD CONSTRAINT $ct_name_q ".
            "FOREIGN KEY ($field_list) REFERENCES $ref_tbl_q ($rfield_list)";

        # The default implicit constraint action in MSSQL is RESTRICT
        # but you can not specify it explicitly. Go figure :)
        my $on_delete = uc ($constraint->on_delete || '');
        my $on_update = uc ($constraint->on_update || '');
        if ( $on_delete && $on_delete ne "NO ACTION" && $on_delete ne "RESTRICT") {
            $c_def .= " ON DELETE $on_delete";
        }
        if ( $on_update && $on_update ne "NO ACTION" && $on_delete ne "RESTRICT") {
            $c_def .= " ON UPDATE $on_update";
        }

        return $c_def, undef;
    }
    elsif ( $type eq PRIMARY_KEY ) {
        my $ct_name=      $constraint->name || unique_name( $constraint->table->name . '_pk' );
        my $ct_name_q=    $util->quote($ct_name);

        my $clause= "CONSTRAINT $ct_name_q PRIMARY KEY ($field_list)";
        my $stmt=   "ALTER TABLE $table_name_q ADD $clause";
        return $stmt, $clause;
    }
    elsif ( $type eq UNIQUE ) {
        my $ct_name=      $constraint->name || unique_name( $constraint->table->name . '_uc' );
        my $ct_name_q=    $util->quote($ct_name);

        my @nullable = grep { $_->is_nullable } $constraint->fields;
        if (!@nullable) {
            my $clause= "CONSTRAINT $ct_name_q UNIQUE ($field_list)";
            my $stmt=   "ALTER TABLE $table_name_q ADD $clause";
            return $stmt, $clause;
        }
        else {
            my $where_clause= join(' AND ', map { $util->quote($_->name) . ' IS NOT NULL' } @nullable );
            my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $ct_name_q" .
                      " ON $table_name_q ($field_list)" .
                      " WHERE $where_clause";
            return $stmt, undef;
        }
    }
    
    die "Unhandled constraint type $type";
}

sub build_index_stmt {
    my ($index, $options)= @_;
    my $table_name_q = $util->quote($index->table->name);
    my $idx_name_q   = $util->quote($index->name);
    my $field_list   = join(', ', map { $util->quote($_) } $index->fields );

    my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $idx_name_q" .
              " ON $table_name_q ($field_list)";
    return $stmt, undef;
}

# -------------------------------------------------------------------
sub unique_name {
    my ($name, $scope, $critical) = @_;

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00"
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to '$name' to make it".
             "unique.\nThis can wreak havoc if you try generating upgrade or".
             "downgrade scripts.\n" if $WARN;

        $scope->{ $name_orig }++;
    }
    $name = substr( $name, 0, $max_id_length )
                        if ((length( $name ) > $max_id_length) && $critical);
    $scope->{ $name }++;
    return $name;
}

1;

# -------------------------------------------------------------------

=pod

=head1 SEE ALSO

SQL::Translator.

=head1 AUTHORS

Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
Sybase producer, I just tweaked it for SQLServer. Thanks.

=cut
Commit	Line	Data
7a0ceaa1	1	package SQL::Translator::Producer::SQLServer;
7a0ceaa1	2
44659089	3	# -------------------------------------------------------------------
	4	# Copyright (C) 2002-2009 SQLFairy Authors
	5	#
	6	# This program is free software; you can redistribute it and/or
	7	# modify it under the terms of the GNU General Public License as
	8	# published by the Free Software Foundation; version 2.
	9	#
	10	# This program is distributed in the hope that it will be useful, but
	11	# WITHOUT ANY WARRANTY; without even the implied warranty of
	12	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	# General Public License for more details.
	14	#
	15	# You should have received a copy of the GNU General Public License
	16	# along with this program; if not, write to the Free Software
	17	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	18	# 02111-1307 USA
	19	# -------------------------------------------------------------------
	20
7a0ceaa1	21	=head1 NAME
	22
	23	SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator
	24
	25	=head1 SYNOPSIS
	26
	27	use SQL::Translator;
	28
	29	my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
	30	$t->translate;
	31
	32	=head1 DESCRIPTION
	33
	34	B<WARNING>B This is still fairly early code, basically a hacked version of the
	35	Sybase Producer (thanks Sam, Paul and Ken for doing the real work ;-)
	36
	37	=head1 Extra Attributes
	38
	39	=over 4
	40
	41	=item field.list
	42
	43	List of values for an enum field.
	44
	45	=back
	46
	47	=head1 TODO
	48
	49	* !! Write some tests !!
	50	* Reserved words list needs updating to SQLServer.
e2fb9ad3	51	* Triggers, Procedures and Views DO NOT WORK
7a0ceaa1	52
	53	=cut
	54
	55	use strict;
da06ac74	56	use vars qw[ $DEBUG $WARN $VERSION ];
11ad2df9	57	$VERSION = '1.59';
7a0ceaa1	58	$DEBUG = 1 unless defined $DEBUG;
	59
	60	use Data::Dumper;
	61	use SQL::Translator::Schema::Constants;
	62	use SQL::Translator::Utils qw(debug header_comment);
f3fccb75	63	use SQL::Translator::ProducerUtils;
0a6e5a56	64
f3fccb75	65	my $util = SQL::Translator::ProducerUtils->new( quote_chars => ['[', ']'] );
7a0ceaa1	66
7a0ceaa1	67	my %translate = (
04627df4	68	date => 'datetime',
	69	'time' => 'datetime',
	70	enum => 'varchar',
	71	bytea => 'varbinary',
	72	blob => 'varbinary',
	73	clob => 'varbinary',
	74	tinyblob => 'varbinary',
	75	mediumblob => 'varbinary',
5bed73f5	76	longblob => 'varbinary',
	77	text => 'varchar', # 'Text' datatype is deprecated in favor of 'varchar(max)'
	78	tinytext => 'varchar',
	79	mediumtext => 'varchar',
	80	longtext => 'varchar',
7a0ceaa1	81	);
7a0ceaa1	82
7a0ceaa1	83	# If these datatypes have size appended the sql fails.
3e0bcbfd	84	my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
7a0ceaa1	85
3e0bcbfd	86	my $max_id_length = 128;
7a0ceaa1	87	my %global_names;
7a0ceaa1	88
	89	=pod
	90
	91	=head1 SQLServer Create Table Syntax
	92
	93	TODO
	94
	95	=cut
	96
	97	# -------------------------------------------------------------------
	98	sub produce {
	99	my $translator = shift;
	100	$DEBUG = $translator->debug;
	101	$WARN = $translator->show_warnings;
	102	my $no_comments = $translator->no_comments;
	103	my $add_drop_table = $translator->add_drop_table;
	104	my $schema = $translator->schema;
04627df4	105	my $options= {
	106	add_drop_table => $add_drop_table,
	107	show_warnings => $WARN,
	108	no_comments => $no_comments,
	109	};
7a0ceaa1	110
e2fb9ad3	111	%global_names = (); #reset
e2fb9ad3	112
7a0ceaa1	113	my $output;
	114	$output .= header_comment."\n" unless ($no_comments);
	115
d02c3cd2	116	# Generate the DROP statements.
7a0ceaa1	117	if ($add_drop_table) {
d02c3cd2	118	my @tables = sort { $b->order <=> $a->order } $schema->get_tables;
	119	$output .= "--\n-- Turn off constraints\n--\n\n" unless $no_comments;
	120	foreach my $table (@tables) {
	121	my $name = $table->name;
04627df4	122	my $q_name = $util->quote( $name );
d02c3cd2	123	$output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') ALTER TABLE $q_name NOCHECK CONSTRAINT all;\n"
	124	}
	125	$output .= "\n";
7a0ceaa1	126	$output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
d02c3cd2	127	foreach my $table (@tables) {
0a6e5a56	128	my $name = $table->name;
04627df4	129	my $q_name = $util->quote( $name );
d02c3cd2	130	$output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $q_name;\n"
7a0ceaa1	131	}
	132	}
	133
	134	# Generate the CREATE sql
f9a5ee79	135
	136	my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
	137
7a0ceaa1	138	for my $table ( $schema->get_tables ) {
04627df4	139	my $table_name = $table->name or next;
04627df4	140	my $table_name_q = $util->quote( $table_name );
7a0ceaa1	141
	142	my ( @comments, @field_defs, @index_defs, @constraint_defs );
	143
04627df4	144	push @comments, "\n\n--\n-- Table: $table_name_q\n--"
7a0ceaa1	145	unless $no_comments;
	146
	147	push @comments, map { "-- $_" } $table->comments;
	148
	149	#
	150	# Fields
	151	#
7a0ceaa1	152	for my $field ( $table->get_fields ) {
04627df4	153	my $field_clause= build_field_clause($field, $options);
	154	if (lc($field->data_type) eq 'enum') {
	155	push @constraint_defs, build_enum_constraint($field, $options);
7a0ceaa1	156	}
04627df4	157	push @field_defs, $field_clause;
7a0ceaa1	158	}
	159
	160	#
	161	# Constraint Declarations
	162	#
04627df4	163	my @constraint_defs = ();
7a0ceaa1	164	for my $constraint ( $table->get_constraints ) {
04627df4	165	next unless $constraint->fields;
	166	my ($stmt, $createClause)= build_constraint_stmt($constraint, $options);
	167	# use a clause, if the constraint can be written that way
	168	if ($createClause) {
	169	push @constraint_defs, $createClause;
f9a5ee79	170	}
04627df4	171	# created a foreign key statement, which we save til the end
	172	elsif ( $constraint->type eq FOREIGN_KEY ) {
	173	push @foreign_constraints, $stmt;
7a0ceaa1	174	}
04627df4	175	# created an index statement, instead of a clause, which we append to "create table"
	176	else { #if ( $constraint->type eq UNIQUE ) {
	177	push @index_defs, $stmt;
7a0ceaa1	178	}
	179	}
	180
	181	#
	182	# Indices
	183	#
	184	for my $index ( $table->get_indices ) {
04627df4	185	my $idx_name = $index->name \|\| unique_name($table_name . '_idx');
04627df4	186	my $idx_name_q = $util->quote($idx_name);
7a0ceaa1	187	push @index_defs,
04627df4	188	"CREATE INDEX $idx_name_q ON $table_name_q (".
04627df4	189	join( ', ', map { $util->quote($_) } $index->fields ) . ");";
7a0ceaa1	190	}
	191
	192	my $create_statement = "";
04627df4	193	$create_statement .= "CREATE TABLE $table_name_q (\n".
028386aa	194	join( ",\n",
7a0ceaa1	195	map { " $_" } @field_defs, @constraint_defs
	196	).
	197	"\n);"
	198	;
	199
	200	$output .= join( "\n\n",
	201	@comments,
	202	$create_statement,
	203	@index_defs,
7a0ceaa1	204	);
	205	}
	206
f9a5ee79	207	# Add FK constraints
	208	$output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
	209
e2fb9ad3	210	# create view/procedure are NOT prepended to the input $sql, needs
	211	# to be filled in with the proper syntax
	212
6fac033a	213	=pod
e2fb9ad3	214
7a0ceaa1	215	# Text of view is already a 'create view' statement so no need to
	216	# be fancy
	217	foreach ( $schema->get_views ) {
	218	my $name = $_->name();
	219	$output .= "\n\n";
5c5997ef	220	$output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
3e0bcbfd	221	my $text = $_->sql();
e2fb9ad3	222	$text =~ s/\r//g;
5bb0a4ee	223	$output .= "$text\nGO\n";
7a0ceaa1	224	}
	225
	226	# Text of procedure already has the 'create procedure' stuff
	227	# so there is no need to do anything fancy. However, we should
	228	# think about doing fancy stuff with granting permissions and
	229	# so on.
	230	foreach ( $schema->get_procedures ) {
	231	my $name = $_->name();
	232	$output .= "\n\n";
5c5997ef	233	$output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
3e0bcbfd	234	my $text = $_->sql();
028386aa	235	$text =~ s/\r//g;
5bb0a4ee	236	$output .= "$text\nGO\n";
7a0ceaa1	237	}
e2fb9ad3	238	=cut
7a0ceaa1	239
	240	return $output;
	241	}
	242
04627df4	243	sub alter_field {
	244	my ($from_field, $to_field, $options) = @_;
	245
	246	my $field_clause= build_field_clause($to_field, $options);
	247	my $table_name_q= $util->quote($to_field->table->name);
	248
	249	my @sql;
	250	if (lc($from_field->data_type) eq 'enum') {
	251	push @sql, build_drop_enum_constraint($from_field, $options).';';
	252	}
	253
	254	push @sql, "ALTER TABLE $table_name_q ALTER COLUMN $field_clause;";
	255
	256	if ($from_field->name ne $to_field->name) {
	257	push @sql, rename_field(@_);
	258	}
	259
	260	if (lc($to_field->data_type) eq 'enum') {
	261	push @sql, build_add_enum_constraint($to_field, $options).';';
	262	}
	263
	264	return join("\n", @sql);
	265	}
	266
	267	sub build_rename_field {
	268	my ($from_field, $to_field, $options) = @_;
	269
	270	return sprintf "EXEC sp_rename \@objname = '%s', \@newname = '%s', \@objtype = 'COLUMN';",
	271	$from_field->name,
	272	$to_field->name;
	273	}
	274
	275	sub add_field {
	276	my ($new_field, $options) = @_;
	277
	278	my $field_clause= build_field_clause(@_);
	279	my $table_name_q= $util->quote($new_field->table->name);
	280
	281	my @sql= "ALTER TABLE $table_name_q ADD COLUMN $field_clause;";
	282	if (lc($new_field->data_type) eq 'enum') {
	283	push @sql, build_add_enum_constraint($new_field, $options).';';
	284	}
	285
	286	return join("\n", @sql);
	287	}
	288
	289	sub drop_field {
	290	my ($old_field, $options) = @_;
	291
	292	my $table_name_q= $util->quote($old_field->table->name);
	293	my $field_name_q= $util->quote($old_field->name);
	294
	295	my @sql;
	296	if (lc($old_field->data_type) eq 'enum') {
	297	push @sql, build_drop_enum_constraint($old_field, $options).';';
	298	}
	299
	300	push @sql, "ALTER TABLE $table_name_q DROP COLUMN $field_name_q;";
	301
	302	return join("\n", @sql);
	303	}
	304
	305	sub alter_create_constraint {
	306	my ($constraint, $options) = @_;
307	my ($stmt, $clause)= build_constraint_stmt(@_);
308	return $stmt.';';
309	}
310
311	sub alter_drop_constraint {
312	my ($constraint, $options) = @_;
313	my $table_name_q= $util->quote($constraint->table->name);
314	my $ct_name_q= $util->quote($constraint->name);
315	return "ALTER TABLE $table_name_q DROP CONSTRAINT $ct_name_q;";
316	}
317
318	sub alter_create_index {
319	my ($index, $options) = @_;
320	my ($stmt, $clause)= build_index_stmt(@_);
321	return $stmt.';';
322	}
323
324	sub alter_drop_index {
325	my ($index, $options) = @_;
326	my $table_name_q= $util->quote($index->table->name);
327	my $index_name_q= $util->quote($index->name);
5bed73f5	328	return "ALTER TABLE $table_name_q DROP $index_name_q;";
	329	}
	330
	331	sub drop_table {
	332	my ($table, $options) = @_;
	333	my $table_name_q= $util->quote($table->name);
	334	return "DROP TABLE $table_name_q;";
04627df4	335	}
	336
	337	sub build_field_clause {
	338	my ($field, $options)= @_;
	339
	340	my $field_name = $field->name;
	341	my $field_name_q = $util->quote($field_name);
	342	my $field_def = $field_name_q;
	343
	344	#
	345	# Datatype
	346	#
	347	my $data_type = lc $field->data_type;
	348	my $orig_data_type = $data_type;
	349	my %extra = $field->extra;
	350	my $list = $extra{'list'} \|\| [];
	351	# \todo deal with embedded quotes
	352	my $commalist = join( ', ', map { qq['$_'] } @$list );
	353	my $size = $field->size;
	354
	355	if ( $data_type eq 'set' ) {
	356	# TODO: do we need more logic here?
	357	$data_type = 'varchar';
	358	}
	359	elsif ( defined $translate{ $data_type } ) {
	360	$data_type = $translate{ $data_type };
	361	}
	362	else {
	363	warn "Unknown datatype: $data_type ",
	364	"(".$field->table->name.".$field_name)\n" if $WARN;
	365	}
	366
	367	if ( grep $_ eq $data_type, @no_size) {
	368	# SQLServer doesn't seem to like sizes on some datatypes
	369	$size = undef;
	370	}
5bed73f5	371	elsif ( $data_type eq 'varbinary' \|\| $data_type eq 'varchar' ) {
04627df4	372	# SQL Server has a max specifyable size of 8000, but if you say 'max', you get 2^31. Go figure.
5bed73f5	373	# Note that 'max' was introduced in SQL Server 2005. Before that, you need a type of 'image'
	374	# or 'text', which is now deprecated.
	375	# TODO: add server-version support and return 'image'/'text' for older versions than 2005
	376	if ($orig_data_type =~ /blob\|text/) {
	377	# mysql tinytext and tinyblob have size of 255, which is our default, below
	378	# else we need 'max'
	379	$size \|\|= 'max' unless $orig_data_type =~ /tiny/;
	380	}
	381	$size \|\|= 255;
	382	# SQL Server barfs on any number greater than 8000, so switch these to 'max'
	383	$size= 'max' if ($size =~ /[0-9]+/) && $size > 8000;
04627df4	384	}
	385	elsif ( !$size ) {
	386	if ( $data_type =~ /numeric/ ) {
	387	$size = '9,0';
	388	}
04627df4	389	elsif (
	390	$data_type eq 'varchar' &&
	391	$orig_data_type eq 'boolean'
	392	) {
	393	$size = '6';
	394	}
	395	elsif ( $data_type eq 'varchar' ) {
	396	$size = '255';
	397	}
	398	}
	399
	400	$field_def .= " $data_type";
	401	$field_def .= "($size)" if $size;
	402
	403	$field_def .= ' IDENTITY' if $field->is_auto_increment;
	404
	405	#
	406	# Not null constraint
	407	#
	408	unless ( $field->is_nullable ) {
	409	$field_def .= ' NOT NULL';
	410	}
	411	else {
	412	$field_def .= ' NULL' if $data_type ne 'bit';
	413	}
	414
	415	#
	416	# Default value
	417	#
	418	SQL::Translator::Producer->_apply_default_value(
	419	$field,
	420	\$field_def,
	421	[
	422	'NULL' => \'NULL',
	423	],
	424	);
	425
	426	return $field_def;
	427	}
	428
	429	sub build_enum_constraint {
	430	my ($field, $options)= @_;
	431	my %extra = $field->extra;
	432	my $list = $extra{'list'} \|\| [];
	433	# \todo deal with embedded quotes
	434	my $commalist = join( ', ', map { qq['$_'] } @$list );
	435	my $field_name_q = $util->quote($field->name);
	436	my $check_name_q = $util->quote( unique_name( $field->table->name . '_' . $field->name . '_chk' ) );
	437	return "CONSTRAINT $check_name_q CHECK ($field_name_q IN ($commalist))";
	438	}
	439
	440	sub build_add_enum_constraint {
	441	my ($field, $options)= @_;
	442	my $table_name_q = $util->quote($field->table->name);
	443	return "ALTER TABLE $table_name_q ADD ".build_enum_constraint(@_);
	444	}
	445
	446	sub build_drop_enum_constraint {
	447	my ($field, $options)= @_;
	448	my $table_name_q = $util->quote($field->table->name);
	449	my $check_name_q = $util->quote( unique_name( $field->table->name . '_' . $field->name . '_chk' ) );
	450	return "ALTER TABLE $table_name_q DROP $check_name_q";
	451	}
	452
453	# build_constraint_stmt($constraint, $options)
454	# Returns ($stmt, $clause)
455	#
456	# Multiple return values are necessary because some things that you would
457	# like to be clauses in CREATE TABLE become separate statements.
458	# $stmt will always be returned, but $clause might be undef
459	#
460	sub build_constraint_stmt {
461	my ($constraint, $options)= @_;
462	my $table_name_q = $util->quote($constraint->table->name);
463	my $field_list = join(', ', map { $util->quote($_) } $constraint->fields );
464	my $type = $constraint->type \|\| NORMAL;
465
466	if ( $type eq FOREIGN_KEY ) {
467	my $ct_name= $constraint->name \|\| unique_name( $constraint->table->name . '_fk' );
468	my $ct_name_q= $util->quote($ct_name);
469	my $ref_tbl_q= $util->quote($constraint->reference_table);
470	my $rfield_list= join( ', ', map { $util->quote($_) } $constraint->reference_fields );
471
472	my $c_def =
473	"ALTER TABLE $table_name_q ADD CONSTRAINT $ct_name_q ".
474	"FOREIGN KEY ($field_list) REFERENCES $ref_tbl_q ($rfield_list)";
475
476	# The default implicit constraint action in MSSQL is RESTRICT
477	# but you can not specify it explicitly. Go figure :)
478	my $on_delete = uc ($constraint->on_delete \|\| '');
479	my $on_update = uc ($constraint->on_update \|\| '');
480	if ( $on_delete && $on_delete ne "NO ACTION" && $on_delete ne "RESTRICT") {
481	$c_def .= " ON DELETE $on_delete";
482	}
483	if ( $on_update && $on_update ne "NO ACTION" && $on_delete ne "RESTRICT") {
484	$c_def .= " ON UPDATE $on_update";
485	}
486
487	return $c_def, undef;
488	}
489	elsif ( $type eq PRIMARY_KEY ) {
490	my $ct_name= $constraint->name \|\| unique_name( $constraint->table->name . '_pk' );
491	my $ct_name_q= $util->quote($ct_name);
492
493	my $clause= "CONSTRAINT $ct_name_q PRIMARY KEY ($field_list)";
494	my $stmt= "ALTER TABLE $table_name_q ADD $clause";
495	return $stmt, $clause;
496	}
497	elsif ( $type eq UNIQUE ) {
498	my $ct_name= $constraint->name \|\| unique_name( $constraint->table->name . '_uc' );
499	my $ct_name_q= $util->quote($ct_name);
500
501	my @nullable = grep { $_->is_nullable } $constraint->fields;
502	if (!@nullable) {
503	my $clause= "CONSTRAINT $ct_name_q UNIQUE ($field_list)";
504	my $stmt= "ALTER TABLE $table_name_q ADD $clause";
505	return $stmt, $clause;
506	}
507	else {
508	my $where_clause= join(' AND ', map { $util->quote($_->name) . ' IS NOT NULL' } @nullable );
509	my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $ct_name_q" .
510	" ON $table_name_q ($field_list)" .
511	" WHERE $where_clause";
512	return $stmt, undef;
513	}
514	}
515
516	die "Unhandled constraint type $type";
517	}
518
519	sub build_index_stmt {
520	my ($index, $options)= @_;
521	my $table_name_q = $util->quote($index->table->name);
522	my $idx_name_q = $util->quote($index->name);
523	my $field_list = join(', ', map { $util->quote($_) } $index->fields );
524
525	my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $idx_name_q" .
526	" ON $table_name_q ($field_list)";
527	return $stmt, undef;
528	}
529
7a0ceaa1	530	# -------------------------------------------------------------------
04627df4	531	sub unique_name {
e2fb9ad3	532	my ($name, $scope, $critical) = @_;
7a0ceaa1	533
	534	$scope \|\|= \%global_names;
	535	if ( my $prev = $scope->{ $name } ) {
	536	my $name_orig = $name;
	537	$name .= sprintf( "%02d", ++$prev );
028386aa	538	substr($name, $max_id_length - 3) = "00"
7a0ceaa1	539	if length( $name ) > $max_id_length;
7a0ceaa1	540
04627df4	541	warn "The name '$name_orig' has been changed to '$name' to make it".
	542	"unique.\nThis can wreak havoc if you try generating upgrade or".
	543	"downgrade scripts.\n" if $WARN;
7a0ceaa1	544
	545	$scope->{ $name_orig }++;
	546	}
028386aa	547	$name = substr( $name, 0, $max_id_length )
7a0ceaa1	548	if ((length( $name ) > $max_id_length) && $critical);
7a0ceaa1	549	$scope->{ $name }++;
04627df4	550	return $name;
7a0ceaa1	551	}
7a0ceaa1	552
7a0ceaa1	553	1;
	554
	555	# -------------------------------------------------------------------
	556
	557	=pod
	558
	559	=head1 SEE ALSO
	560
	561	SQL::Translator.
	562
	563	=head1 AUTHORS
	564
	565	Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
	566	Sybase producer, I just tweaked it for SQLServer. Thanks.
	567
	568	=cut