[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.60';
$DEBUG = 1 unless defined $DEBUG;

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

my %translate  = (
    date      => 'datetime',
    'time'    => 'datetime',
    # Sybase types
    #integer   => 'numeric',
    #int       => 'numeric',
    #number    => 'numeric',
    #money     => 'money',
    #varchar   => 'varchar',
    #varchar2  => 'varchar',
    #timestamp => 'datetime',
    #text      => 'varchar',
    #real      => 'double precision',
    #comment   => 'text',
    #bit       => 'bit',
    #tinyint   => 'smallint',
    #float     => 'double precision',
    #serial    => 'numeric', 
    #boolean   => 'varchar',
    #char      => 'char',
    #long      => 'varchar',
);

# TODO - This is still the Sybase list!
my %reserved = map { $_, 1 } qw[
    ALL ANALYSE ANALYZE AND ANY AS ASC 
    BETWEEN BINARY BOTH
    CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
    CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER 
    DEFAULT DEFERRABLE DESC DISTINCT DO
    ELSE END EXCEPT
    FALSE FOR FOREIGN FREEZE FROM FULL 
    GROUP HAVING 
    ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL 
    JOIN LEADING LEFT LIKE LIMIT 
    NATURAL NEW NOT NOTNULL NULL
    OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
    PRIMARY PUBLIC REFERENCES RIGHT 
    SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE 
    UNION UNIQUE USER USING VERBOSE WHEN WHERE
];

# 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;
my %unreserve;

=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;

    %global_names = (); #reset
    %unreserve = ();

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

    # Generate the DROP statements. We do this in one block here as if we
    # have fkeys we need to drop in the correct order otherwise they will fail
    # due to the dependancies the fkeys setup. (There is no way to turn off
    # fkey checking while we sort the schema like MySQL's set
    # foreign_key_checks=0)
    # We assume the tables are in the correct order to set them up as you need
    # to have created a table to fkey to it. So the reverse order should drop
    # them properly, fingers crossed...
    if ($add_drop_table) {
        $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
        foreach my $table (
            sort { $b->order <=> $a->order } $schema->get_tables
        ) {
            my $name = unreserve($table->name);
            $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\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_ur = unreserve($table_name) || '';

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

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

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

        #
        # Fields
        #
        my %field_name_scope;
        for my $field ( $table->get_fields ) {
            my $field_name    = $field->name;
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_def     = qq["$field_name_ur"];
            $field_def        =~ s/\"//g;
            if ( $field_def =~ /identity/ ){
                $field_def =~ s/identity/pidentity/;
            }

            #
            # 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 );

            if ( $data_type eq 'enum' ) {
                my $check_name = mk_name( $field_name . '_chk' );
                push @constraint_defs,
                  "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
                $data_type .= 'character varying';
            }
            elsif ( $data_type eq 'set' ) {
                $data_type .= 'character varying';
            }
            elsif ( grep { $data_type eq $_ } qw/bytea blob clob/ ) {
                $data_type = 'varbinary';
            }
            else {
                if ( defined $translate{ $data_type } ) {
                    $data_type = $translate{ $data_type };
                }
                else {
                    warn "Unknown datatype: $data_type ",
                        "($table_name.$field_name)\n" if $WARN;
                }
            }

            my $size = $field->size;
            if ( grep $_ eq $data_type, @no_size) {
            # SQLServer doesn't seem to like sizes on some datatypes
                $size = undef;
            }
            elsif ( !$size ) {
                if ( $data_type =~ /numeric/ ) {
                    $size = '9,0';
                }
                elsif ( $orig_data_type eq 'text' ) {
                    #interpret text fields as long varchars
                    $size = '255';
                }
                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
            #
            my $default = $field->default_value;
            if ( defined $default ) {
                SQL::Translator::Producer->_apply_default_value(
                  \$field_def,
                  $default, 
                  [
                    'NULL'       => \'NULL',
                  ],
                );
            }

            push @field_defs, $field_def;            
        }

        #
        # Constraint Declarations
        #
        my @constraint_decs = ();
        for my $constraint ( $table->get_constraints ) {
            my $name    = $constraint->name || '';
            # Make sure we get a unique name
            my $type    = $constraint->type || NORMAL;
            my @fields  = map { unreserve( $_, $table_name ) }
                $constraint->fields;
            my @rfields = map { unreserve( $_, $table_name ) }
                $constraint->reference_fields;
            next unless @fields;

            my $c_def;
            if ( $type eq FOREIGN_KEY ) {
                $name ||= mk_name( $table_name . '_fk' );
                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 ($on_delete, $on_update) {
                  undef $_ if $_ eq 'RESTRICT'
                }

                $c_def = 
                    "ALTER TABLE $table_name ADD CONSTRAINT $name FOREIGN KEY".
                    ' (' . join( ', ', @fields ) . ') REFERENCES '.
                    $constraint->reference_table.
                    ' (' . join( ', ', @rfields ) . ')'
                ;

                if ( $on_delete && $on_delete ne "NO ACTION") {
                  $c_def .= " ON DELETE $on_delete";
                }
                if ( $on_update && $on_update ne "NO ACTION") {
                  $c_def .= " ON UPDATE $on_update";
                }

                $c_def .= ";";

                push @foreign_constraints, $c_def;
                next;
            }


            if ( $type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name . '_pk' );
                $c_def = 
                    "CONSTRAINT $name PRIMARY KEY ".
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $type eq UNIQUE ) {
                $name ||= mk_name( $table_name . '_uc' );
                $c_def = 
                    "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
            push @constraint_defs, $c_def;
        }

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

        my $create_statement = "";
        $create_statement .= qq[CREATE TABLE $table_name_ur (\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 mk_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.\n" if $WARN;

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

# -------------------------------------------------------------------
sub unreserve {
    my $name            = shift || '';
    my $schema_obj_name = shift || '';
    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i; 

    if ( $schema_obj_name ) {
        ++$unreserve{"$schema_obj_name.$name"};
    }
    else {
        ++$unreserve{"$name (table name)"};
    }

    my $unreserve = sprintf '%s_', $name;
    return $unreserve.$suffix;
}

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;
	2
	3	# -------------------------------------------------------------------
478f608d	4	# Copyright (C) 2002-2009 SQLFairy Authors
7a0ceaa1	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
	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 ];
ba506e52	57	$VERSION = '1.60';
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);
	63
	64	my %translate = (
	65	date => 'datetime',
	66	'time' => 'datetime',
	67	# Sybase types
	68	#integer => 'numeric',
	69	#int => 'numeric',
	70	#number => 'numeric',
	71	#money => 'money',
	72	#varchar => 'varchar',
	73	#varchar2 => 'varchar',
	74	#timestamp => 'datetime',
	75	#text => 'varchar',
	76	#real => 'double precision',
	77	#comment => 'text',
	78	#bit => 'bit',
	79	#tinyint => 'smallint',
	80	#float => 'double precision',
	81	#serial => 'numeric',
	82	#boolean => 'varchar',
	83	#char => 'char',
	84	#long => 'varchar',
	85	);
	86
	87	# TODO - This is still the Sybase list!
	88	my %reserved = map { $_, 1 } qw[
	89	ALL ANALYSE ANALYZE AND ANY AS ASC
	90	BETWEEN BINARY BOTH
	91	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	92	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	93	DEFAULT DEFERRABLE DESC DISTINCT DO
	94	ELSE END EXCEPT
	95	FALSE FOR FOREIGN FREEZE FROM FULL
	96	GROUP HAVING
	97	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	98	JOIN LEADING LEFT LIKE LIMIT
	99	NATURAL NEW NOT NOTNULL NULL
	100	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	101	PRIMARY PUBLIC REFERENCES RIGHT
	102	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	103	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	104	];
	105
	106	# If these datatypes have size appended the sql fails.
3e0bcbfd	107	my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
7a0ceaa1	108
3e0bcbfd	109	my $max_id_length = 128;
7a0ceaa1	110	my %global_names;
7a0ceaa1	111	my %unreserve;
7a0ceaa1	112
	113	=pod
	114
	115	=head1 SQLServer Create Table Syntax
	116
	117	TODO
	118
	119	=cut
	120
	121	# -------------------------------------------------------------------
	122	sub produce {
	123	my $translator = shift;
	124	$DEBUG = $translator->debug;
	125	$WARN = $translator->show_warnings;
	126	my $no_comments = $translator->no_comments;
	127	my $add_drop_table = $translator->add_drop_table;
	128	my $schema = $translator->schema;
	129
e2fb9ad3	130	%global_names = (); #reset
	131	%unreserve = ();
	132
7a0ceaa1	133	my $output;
	134	$output .= header_comment."\n" unless ($no_comments);
	135
	136	# Generate the DROP statements. We do this in one block here as if we
	137	# have fkeys we need to drop in the correct order otherwise they will fail
	138	# due to the dependancies the fkeys setup. (There is no way to turn off
	139	# fkey checking while we sort the schema like MySQL's set
	140	# foreign_key_checks=0)
	141	# We assume the tables are in the correct order to set them up as you need
	142	# to have created a table to fkey to it. So the reverse order should drop
	143	# them properly, fingers crossed...
	144	if ($add_drop_table) {
	145	$output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
	146	foreach my $table (
	147	sort { $b->order <=> $a->order } $schema->get_tables
	148	) {
	149	my $name = unreserve($table->name);
	150	$output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
	151	}
	152	}
	153
	154	# Generate the CREATE sql
f9a5ee79	155
	156	my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
	157
7a0ceaa1	158	for my $table ( $schema->get_tables ) {
7a0ceaa1	159	my $table_name = $table->name or next;
7a0ceaa1	160	my $table_name_ur = unreserve($table_name) \|\| '';
	161
	162	my ( @comments, @field_defs, @index_defs, @constraint_defs );
	163
	164	push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
	165	unless $no_comments;
	166
	167	push @comments, map { "-- $_" } $table->comments;
	168
	169	#
	170	# Fields
	171	#
	172	my %field_name_scope;
	173	for my $field ( $table->get_fields ) {
e2fb9ad3	174	my $field_name = $field->name;
7a0ceaa1	175	my $field_name_ur = unreserve( $field_name, $table_name );
	176	my $field_def = qq["$field_name_ur"];
	177	$field_def =~ s/\"//g;
	178	if ( $field_def =~ /identity/ ){
	179	$field_def =~ s/identity/pidentity/;
	180	}
	181
	182	#
	183	# Datatype
	184	#
	185	my $data_type = lc $field->data_type;
	186	my $orig_data_type = $data_type;
	187	my %extra = $field->extra;
	188	my $list = $extra{'list'} \|\| [];
	189	# \todo deal with embedded quotes
	190	my $commalist = join( ', ', map { qq['$_'] } @$list );
7a0ceaa1	191
7a0ceaa1	192	if ( $data_type eq 'enum' ) {
e2fb9ad3	193	my $check_name = mk_name( $field_name . '_chk' );
7a0ceaa1	194	push @constraint_defs,
e2fb9ad3	195	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
7a0ceaa1	196	$data_type .= 'character varying';
	197	}
	198	elsif ( $data_type eq 'set' ) {
	199	$data_type .= 'character varying';
	200	}
f9a5ee79	201	elsif ( grep { $data_type eq $_ } qw/bytea blob clob/ ) {
	202	$data_type = 'varbinary';
	203	}
7a0ceaa1	204	else {
	205	if ( defined $translate{ $data_type } ) {
	206	$data_type = $translate{ $data_type };
	207	}
	208	else {
	209	warn "Unknown datatype: $data_type ",
	210	"($table_name.$field_name)\n" if $WARN;
	211	}
	212	}
	213
	214	my $size = $field->size;
	215	if ( grep $_ eq $data_type, @no_size) {
	216	# SQLServer doesn't seem to like sizes on some datatypes
	217	$size = undef;
	218	}
	219	elsif ( !$size ) {
	220	if ( $data_type =~ /numeric/ ) {
	221	$size = '9,0';
	222	}
	223	elsif ( $orig_data_type eq 'text' ) {
	224	#interpret text fields as long varchars
	225	$size = '255';
	226	}
	227	elsif (
	228	$data_type eq 'varchar' &&
	229	$orig_data_type eq 'boolean'
	230	) {
	231	$size = '6';
	232	}
	233	elsif ( $data_type eq 'varchar' ) {
	234	$size = '255';
	235	}
	236	}
	237
	238	$field_def .= " $data_type";
	239	$field_def .= "($size)" if $size;
	240
	241	$field_def .= ' IDENTITY' if $field->is_auto_increment;
	242
	243	#
1426be03	244	# Not null constraint
	245	#
	246	unless ( $field->is_nullable ) {
	247	$field_def .= ' NOT NULL';
	248	}
	249	else {
	250	$field_def .= ' NULL' if $data_type ne 'bit';
	251	}
1426be03	252
1426be03	253	#
7a0ceaa1	254	# Default value
	255	#
	256	my $default = $field->default_value;
	257	if ( defined $default ) {
bc8e2aa1	258	SQL::Translator::Producer->_apply_default_value(
	259	\$field_def,
	260	$default,
	261	[
	262	'NULL' => \'NULL',
	263	],
7a0ceaa1	264	);
7a0ceaa1	265	}
bc8e2aa1	266
a7763b79	267	push @field_defs, $field_def;
7a0ceaa1	268	}
	269
	270	#
	271	# Constraint Declarations
	272	#
	273	my @constraint_decs = ();
7a0ceaa1	274	for my $constraint ( $table->get_constraints ) {
	275	my $name = $constraint->name \|\| '';
	276	# Make sure we get a unique name
7a0ceaa1	277	my $type = $constraint->type \|\| NORMAL;
	278	my @fields = map { unreserve( $_, $table_name ) }
	279	$constraint->fields;
	280	my @rfields = map { unreserve( $_, $table_name ) }
	281	$constraint->reference_fields;
	282	next unless @fields;
	283
5bac76bc	284	my $c_def;
f9a5ee79	285	if ( $type eq FOREIGN_KEY ) {
e2fb9ad3	286	$name \|\|= mk_name( $table_name . '_fk' );
5bac76bc	287	my $on_delete = uc ($constraint->on_delete \|\| '');
	288	my $on_update = uc ($constraint->on_update \|\| '');
	289
	290	# The default implicit constraint action in MSSQL is RESTRICT
	291	# but you can not specify it explicitly. Go figure :)
	292	for ($on_delete, $on_update) {
	293	undef $_ if $_ eq 'RESTRICT'
	294	}
	295
04a180d6	296	$c_def =
f9a5ee79	297	"ALTER TABLE $table_name ADD CONSTRAINT $name FOREIGN KEY".
7a0ceaa1	298	' (' . join( ', ', @fields ) . ') REFERENCES '.
7a0ceaa1	299	$constraint->reference_table.
f9a5ee79	300	' (' . join( ', ', @rfields ) . ')'
	301	;
	302
5bac76bc	303	if ( $on_delete && $on_delete ne "NO ACTION") {
	304	$c_def .= " ON DELETE $on_delete";
	305	}
	306	if ( $on_update && $on_update ne "NO ACTION") {
	307	$c_def .= " ON UPDATE $on_update";
	308	}
f9a5ee79	309
	310	$c_def .= ";";
	311
	312	push @foreign_constraints, $c_def;
	313	next;
	314	}
	315
	316
	317	if ( $type eq PRIMARY_KEY ) {
	318	$name \|\|= mk_name( $table_name . '_pk' );
	319	$c_def =
	320	"CONSTRAINT $name PRIMARY KEY ".
	321	'(' . join( ', ', @fields ) . ')';
7a0ceaa1	322	}
7a0ceaa1	323	elsif ( $type eq UNIQUE ) {
e2fb9ad3	324	$name \|\|= mk_name( $table_name . '_uc' );
04a180d6	325	$c_def =
7a0ceaa1	326	"CONSTRAINT $name UNIQUE " .
	327	'(' . join( ', ', @fields ) . ')';
	328	}
04a180d6	329	push @constraint_defs, $c_def;
7a0ceaa1	330	}
	331
	332	#
	333	# Indices
	334	#
	335	for my $index ( $table->get_indices ) {
e2fb9ad3	336	my $idx_name = $index->name \|\| mk_name($table_name . '_idx');
7a0ceaa1	337	push @index_defs,
	338	"CREATE INDEX $idx_name ON $table_name (".
	339	join( ', ', $index->fields ) . ");";
	340	}
	341
	342	my $create_statement = "";
	343	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
	344	join( ",\n",
	345	map { " $_" } @field_defs, @constraint_defs
	346	).
	347	"\n);"
	348	;
	349
	350	$output .= join( "\n\n",
	351	@comments,
	352	$create_statement,
	353	@index_defs,
7a0ceaa1	354	);
	355	}
	356
f9a5ee79	357	# Add FK constraints
	358	$output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
	359
e2fb9ad3	360	# create view/procedure are NOT prepended to the input $sql, needs
	361	# to be filled in with the proper syntax
	362
6fac033a	363	=pod
e2fb9ad3	364
7a0ceaa1	365	# Text of view is already a 'create view' statement so no need to
	366	# be fancy
	367	foreach ( $schema->get_views ) {
	368	my $name = $_->name();
	369	$output .= "\n\n";
5c5997ef	370	$output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
3e0bcbfd	371	my $text = $_->sql();
e2fb9ad3	372	$text =~ s/\r//g;
5bb0a4ee	373	$output .= "$text\nGO\n";
7a0ceaa1	374	}
	375
	376	# Text of procedure already has the 'create procedure' stuff
	377	# so there is no need to do anything fancy. However, we should
	378	# think about doing fancy stuff with granting permissions and
	379	# so on.
	380	foreach ( $schema->get_procedures ) {
	381	my $name = $_->name();
	382	$output .= "\n\n";
5c5997ef	383	$output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
3e0bcbfd	384	my $text = $_->sql();
3e0bcbfd	385	$text =~ s/\r//g;
5bb0a4ee	386	$output .= "$text\nGO\n";
7a0ceaa1	387	}
e2fb9ad3	388	=cut
7a0ceaa1	389
	390	return $output;
	391	}
	392
	393	# -------------------------------------------------------------------
	394	sub mk_name {
e2fb9ad3	395	my ($name, $scope, $critical) = @_;
7a0ceaa1	396
	397	$scope \|\|= \%global_names;
	398	if ( my $prev = $scope->{ $name } ) {
	399	my $name_orig = $name;
	400	$name .= sprintf( "%02d", ++$prev );
	401	substr($name, $max_id_length - 3) = "00"
	402	if length( $name ) > $max_id_length;
	403
	404	warn "The name '$name_orig' has been changed to ",
	405	"'$name' to make it unique.\n" if $WARN;
	406
	407	$scope->{ $name_orig }++;
	408	}
	409	$name = substr( $name, 0, $max_id_length )
	410	if ((length( $name ) > $max_id_length) && $critical);
	411	$scope->{ $name }++;
	412	return $name;
	413	}
	414
	415	# -------------------------------------------------------------------
	416	sub unreserve {
	417	my $name = shift \|\| '';
	418	my $schema_obj_name = shift \|\| '';
	419	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	420
	421	# also trap fields that don't begin with a letter
	422	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
	423
	424	if ( $schema_obj_name ) {
	425	++$unreserve{"$schema_obj_name.$name"};
	426	}
	427	else {
	428	++$unreserve{"$name (table name)"};
	429	}
	430
	431	my $unreserve = sprintf '%s_', $name;
	432	return $unreserve.$suffix;
	433	}
	434
	435	1;
	436
	437	# -------------------------------------------------------------------
	438
	439	=pod
	440
	441	=head1 SEE ALSO
	442
	443	SQL::Translator.
	444
	445	=head1 AUTHORS
	446
	447	Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
	448	Sybase producer, I just tweaked it for SQLServer. Thanks.
	449
	450	=cut