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

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

# -------------------------------------------------------------------
# $Id: SQLServer.pm 1440 2009-01-17 16:31:57Z jawnsy $
# -------------------------------------------------------------------
# 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 havn't been tested at all.

=cut

use strict;
use vars qw[ $DEBUG $WARN ];
$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 %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;

=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 $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
    for my $table ( $schema->get_tables ) {
        my $table_name    = $table->name or next;
        $table_name       = mk_name( $table_name, '', undef, 1 );
        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    = mk_name(
                $field->name, '', \%field_name_scope, undef,1 
            );
            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(
                    $table_name.'_'.$field_name, 'chk' ,undef, 1
                );
                push @constraint_defs,
                "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
                $data_type .= 'character varying';
            }
            elsif ( $data_type eq 'set' ) {
                $data_type .= 'character varying';
            }
            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 = ();
        my $c_name_default;
        for my $constraint ( $table->get_constraints ) {
            my $name    = $constraint->name || '';
            # Make sure we get a unique name
            $name       = mk_name( $name, undef, undef, 1 ) if $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 PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk', undef,1 );
                $c_def = 
                    "CONSTRAINT $name PRIMARY KEY ".
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $type eq FOREIGN_KEY ) {
                $name ||= mk_name( $table_name, 'fk', undef,1 );
                #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
                $c_def = 
                    "CONSTRAINT $name FOREIGN KEY".
                    ' (' . join( ', ', @fields ) . ') REFERENCES '.
                    $constraint->reference_table.
                    ' (' . join( ', ', @rfields ) . ')';
                 my $on_delete = $constraint->on_delete;
                 if ( defined $on_delete && $on_delete ne "NO ACTION") {
                 	$c_def .= " ON DELETE $on_delete";
                 }
                 my $on_update = $constraint->on_update;
                 if ( defined $on_update && $on_update ne "NO ACTION") {
                 	$c_def .= " ON UPDATE $on_update";
                 }
            }
            elsif ( $type eq UNIQUE ) {
                $name ||= mk_name(
                    $table_name,
                    $name || ++$c_name_default,undef, 1
                );
                $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',undef,1);
            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,
            ''
        );
    }

    # 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";
    }

    # Warn out how we messed with the names.
    if ( $WARN ) {
        if ( %truncated ) {
            warn "Truncated " . keys( %truncated ) . " names:\n";
            warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
        }
        if ( %unreserve ) {
            warn "Encounted " . keys( %unreserve ) .
                " unsafe names in schema (reserved or invalid):\n";
            warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
        }
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my $basename      = shift || '';
    my $type          = shift || '';
    my $scope         = shift || '';
    my $critical      = shift || '';
    my $basename_orig = $basename;
    my $max_name      = $type
                        ? $max_id_length - (length($type) + 1)
                        : $max_id_length;
    $basename         = substr( $basename, 0, $max_name )
                        if length( $basename ) > $max_name;
    my $name          = $type ? "${type}_$basename" : $basename;

    if ( $basename ne $basename_orig and $critical ) {
        my $show_type = $type ? "+'$type'" : "";
        warn "Truncating '$basename_orig'$show_type to $max_id_length ",
            "character limit to make '$name'\n" if $WARN;
        $truncated{ $basename_orig } = $name;
    }

    $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	# -------------------------------------------------------------------
d4f84dd1	4	# $Id: SQLServer.pm 1440 2009-01-17 16:31:57Z jawnsy $
7a0ceaa1	5	# -------------------------------------------------------------------
478f608d	6	# Copyright (C) 2002-2009 SQLFairy Authors
7a0ceaa1	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=head1 NAME
	24
	25	SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator
	26
	27	=head1 SYNOPSIS
	28
	29	use SQL::Translator;
	30
	31	my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
	32	$t->translate;
	33
	34	=head1 DESCRIPTION
	35
	36	B<WARNING>B This is still fairly early code, basically a hacked version of the
	37	Sybase Producer (thanks Sam, Paul and Ken for doing the real work ;-)
	38
	39	=head1 Extra Attributes
	40
	41	=over 4
	42
	43	=item field.list
	44
	45	List of values for an enum field.
	46
	47	=back
	48
	49	=head1 TODO
	50
	51	* !! Write some tests !!
	52	* Reserved words list needs updating to SQLServer.
	53	* Triggers, Procedures and Views havn't been tested at all.
	54
	55	=cut
	56
	57	use strict;
478f608d	58	use vars qw[ $DEBUG $WARN ];
7a0ceaa1	59	$DEBUG = 1 unless defined $DEBUG;
	60
	61	use Data::Dumper;
	62	use SQL::Translator::Schema::Constants;
	63	use SQL::Translator::Utils qw(debug header_comment);
	64
	65	my %translate = (
	66	date => 'datetime',
	67	'time' => 'datetime',
	68	# Sybase types
	69	#integer => 'numeric',
	70	#int => 'numeric',
	71	#number => 'numeric',
	72	#money => 'money',
	73	#varchar => 'varchar',
	74	#varchar2 => 'varchar',
	75	#timestamp => 'datetime',
	76	#text => 'varchar',
	77	#real => 'double precision',
	78	#comment => 'text',
	79	#bit => 'bit',
	80	#tinyint => 'smallint',
	81	#float => 'double precision',
	82	#serial => 'numeric',
	83	#boolean => 'varchar',
	84	#char => 'char',
	85	#long => 'varchar',
	86	);
	87
	88	# TODO - This is still the Sybase list!
	89	my %reserved = map { $_, 1 } qw[
	90	ALL ANALYSE ANALYZE AND ANY AS ASC
	91	BETWEEN BINARY BOTH
	92	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	93	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	94	DEFAULT DEFERRABLE DESC DISTINCT DO
	95	ELSE END EXCEPT
	96	FALSE FOR FOREIGN FREEZE FROM FULL
	97	GROUP HAVING
	98	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	99	JOIN LEADING LEFT LIKE LIMIT
	100	NATURAL NEW NOT NOTNULL NULL
	101	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	102	PRIMARY PUBLIC REFERENCES RIGHT
	103	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	104	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	105	];
	106
	107	# If these datatypes have size appended the sql fails.
3e0bcbfd	108	my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
7a0ceaa1	109
3e0bcbfd	110	my $max_id_length = 128;
7a0ceaa1	111	my %used_identifiers = ();
	112	my %global_names;
	113	my %unreserve;
	114	my %truncated;
	115
	116	=pod
	117
	118	=head1 SQLServer Create Table Syntax
	119
	120	TODO
	121
	122	=cut
	123
	124	# -------------------------------------------------------------------
	125	sub produce {
	126	my $translator = shift;
	127	$DEBUG = $translator->debug;
	128	$WARN = $translator->show_warnings;
	129	my $no_comments = $translator->no_comments;
	130	my $add_drop_table = $translator->add_drop_table;
	131	my $schema = $translator->schema;
	132
	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
	155	for my $table ( $schema->get_tables ) {
	156	my $table_name = $table->name or next;
	157	$table_name = mk_name( $table_name, '', undef, 1 );
	158	my $table_name_ur = unreserve($table_name) \|\| '';
	159
	160	my ( @comments, @field_defs, @index_defs, @constraint_defs );
	161
	162	push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
	163	unless $no_comments;
	164
	165	push @comments, map { "-- $_" } $table->comments;
	166
	167	#
	168	# Fields
	169	#
	170	my %field_name_scope;
	171	for my $field ( $table->get_fields ) {
	172	my $field_name = mk_name(
	173	$field->name, '', \%field_name_scope, undef,1
	174	);
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
	192	if ( $data_type eq 'enum' ) {
	193	my $check_name = mk_name(
	194	$table_name.'_'.$field_name, 'chk' ,undef, 1
	195	);
	196	push @constraint_defs,
	197	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
	198	$data_type .= 'character varying';
	199	}
	200	elsif ( $data_type eq 'set' ) {
	201	$data_type .= 'character varying';
	202	}
	203	else {
	204	if ( defined $translate{ $data_type } ) {
	205	$data_type = $translate{ $data_type };
	206	}
	207	else {
	208	warn "Unknown datatype: $data_type ",
	209	"($table_name.$field_name)\n" if $WARN;
	210	}
	211	}
	212
	213	my $size = $field->size;
	214	if ( grep $_ eq $data_type, @no_size) {
	215	# SQLServer doesn't seem to like sizes on some datatypes
	216	$size = undef;
	217	}
	218	elsif ( !$size ) {
	219	if ( $data_type =~ /numeric/ ) {
	220	$size = '9,0';
	221	}
	222	elsif ( $orig_data_type eq 'text' ) {
	223	#interpret text fields as long varchars
	224	$size = '255';
	225	}
	226	elsif (
	227	$data_type eq 'varchar' &&
	228	$orig_data_type eq 'boolean'
	229	) {
	230	$size = '6';
	231	}
	232	elsif ( $data_type eq 'varchar' ) {
	233	$size = '255';
	234	}
	235	}
	236
	237	$field_def .= " $data_type";
	238	$field_def .= "($size)" if $size;
	239
	240	$field_def .= ' IDENTITY' if $field->is_auto_increment;
	241
	242	#
1426be03	243	# Not null constraint
	244	#
	245	unless ( $field->is_nullable ) {
	246	$field_def .= ' NOT NULL';
	247	}
	248	else {
	249	$field_def .= ' NULL' if $data_type ne 'bit';
	250	}
1426be03	251
1426be03	252	#
7a0ceaa1	253	# Default value
	254	#
	255	my $default = $field->default_value;
	256	if ( defined $default ) {
bc8e2aa1	257	SQL::Translator::Producer->_apply_default_value(
	258	\$field_def,
	259	$default,
	260	[
	261	'NULL' => \'NULL',
	262	],
7a0ceaa1	263	);
7a0ceaa1	264	}
bc8e2aa1	265
a7763b79	266	push @field_defs, $field_def;
7a0ceaa1	267	}
	268
	269	#
	270	# Constraint Declarations
	271	#
	272	my @constraint_decs = ();
	273	my $c_name_default;
	274	for my $constraint ( $table->get_constraints ) {
	275	my $name = $constraint->name \|\| '';
	276	# Make sure we get a unique name
	277	$name = mk_name( $name, undef, undef, 1 ) if $name;
	278	my $type = $constraint->type \|\| NORMAL;
	279	my @fields = map { unreserve( $_, $table_name ) }
	280	$constraint->fields;
	281	my @rfields = map { unreserve( $_, $table_name ) }
	282	$constraint->reference_fields;
	283	next unless @fields;
	284
04a180d6	285	my $c_def;
7a0ceaa1	286	if ( $type eq PRIMARY_KEY ) {
7a0ceaa1	287	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
04a180d6	288	$c_def =
7a0ceaa1	289	"CONSTRAINT $name PRIMARY KEY ".
	290	'(' . join( ', ', @fields ) . ')';
	291	}
	292	elsif ( $type eq FOREIGN_KEY ) {
	293	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	294	#$name = mk_name( ($name \|\| $table_name), 'fk', undef,1 );
04a180d6	295	$c_def =
7a0ceaa1	296	"CONSTRAINT $name FOREIGN KEY".
	297	' (' . join( ', ', @fields ) . ') REFERENCES '.
	298	$constraint->reference_table.
	299	' (' . join( ', ', @rfields ) . ')';
04a180d6	300	my $on_delete = $constraint->on_delete;
	301	if ( defined $on_delete && $on_delete ne "NO ACTION") {
	302	$c_def .= " ON DELETE $on_delete";
	303	}
	304	my $on_update = $constraint->on_update;
	305	if ( defined $on_update && $on_update ne "NO ACTION") {
	306	$c_def .= " ON UPDATE $on_update";
	307	}
7a0ceaa1	308	}
	309	elsif ( $type eq UNIQUE ) {
	310	$name \|\|= mk_name(
	311	$table_name,
	312	$name \|\| ++$c_name_default,undef, 1
	313	);
04a180d6	314	$c_def =
7a0ceaa1	315	"CONSTRAINT $name UNIQUE " .
	316	'(' . join( ', ', @fields ) . ')';
	317	}
04a180d6	318	push @constraint_defs, $c_def;
7a0ceaa1	319	}
	320
	321	#
	322	# Indices
	323	#
	324	for my $index ( $table->get_indices ) {
	325	my $idx_name = $index->name \|\| mk_name($table_name,'idx',undef,1);
	326	push @index_defs,
	327	"CREATE INDEX $idx_name ON $table_name (".
	328	join( ', ', $index->fields ) . ");";
	329	}
	330
	331	my $create_statement = "";
	332	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
	333	join( ",\n",
	334	map { " $_" } @field_defs, @constraint_defs
	335	).
	336	"\n);"
	337	;
	338
	339	$output .= join( "\n\n",
	340	@comments,
	341	$create_statement,
	342	@index_defs,
	343	''
	344	);
	345	}
	346
	347	# Text of view is already a 'create view' statement so no need to
	348	# be fancy
	349	foreach ( $schema->get_views ) {
	350	my $name = $_->name();
	351	$output .= "\n\n";
5c5997ef	352	$output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
3e0bcbfd	353	my $text = $_->sql();
3e0bcbfd	354	$text =~ s/\r//g;
5bb0a4ee	355	$output .= "$text\nGO\n";
7a0ceaa1	356	}
	357
	358	# Text of procedure already has the 'create procedure' stuff
	359	# so there is no need to do anything fancy. However, we should
	360	# think about doing fancy stuff with granting permissions and
	361	# so on.
	362	foreach ( $schema->get_procedures ) {
	363	my $name = $_->name();
	364	$output .= "\n\n";
5c5997ef	365	$output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
3e0bcbfd	366	my $text = $_->sql();
3e0bcbfd	367	$text =~ s/\r//g;
5bb0a4ee	368	$output .= "$text\nGO\n";
7a0ceaa1	369	}
	370
	371	# Warn out how we messed with the names.
	372	if ( $WARN ) {
	373	if ( %truncated ) {
	374	warn "Truncated " . keys( %truncated ) . " names:\n";
	375	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	376	}
	377	if ( %unreserve ) {
	378	warn "Encounted " . keys( %unreserve ) .
	379	" unsafe names in schema (reserved or invalid):\n";
	380	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	381	}
	382	}
	383
	384	return $output;
	385	}
	386
	387	# -------------------------------------------------------------------
	388	sub mk_name {
	389	my $basename = shift \|\| '';
	390	my $type = shift \|\| '';
	391	my $scope = shift \|\| '';
	392	my $critical = shift \|\| '';
	393	my $basename_orig = $basename;
	394	my $max_name = $type
	395	? $max_id_length - (length($type) + 1)
	396	: $max_id_length;
	397	$basename = substr( $basename, 0, $max_name )
	398	if length( $basename ) > $max_name;
	399	my $name = $type ? "${type}_$basename" : $basename;
	400
	401	if ( $basename ne $basename_orig and $critical ) {
	402	my $show_type = $type ? "+'$type'" : "";
	403	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	404	"character limit to make '$name'\n" if $WARN;
	405	$truncated{ $basename_orig } = $name;
	406	}
	407
	408	$scope \|\|= \%global_names;
	409	if ( my $prev = $scope->{ $name } ) {
	410	my $name_orig = $name;
	411	$name .= sprintf( "%02d", ++$prev );
	412	substr($name, $max_id_length - 3) = "00"
	413	if length( $name ) > $max_id_length;
	414
	415	warn "The name '$name_orig' has been changed to ",
	416	"'$name' to make it unique.\n" if $WARN;
	417
	418	$scope->{ $name_orig }++;
	419	}
	420	$name = substr( $name, 0, $max_id_length )
	421	if ((length( $name ) > $max_id_length) && $critical);
	422	$scope->{ $name }++;
	423	return $name;
	424	}
	425
	426	# -------------------------------------------------------------------
	427	sub unreserve {
	428	my $name = shift \|\| '';
	429	my $schema_obj_name = shift \|\| '';
	430	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	431
	432	# also trap fields that don't begin with a letter
433	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
434
435	if ( $schema_obj_name ) {
436	++$unreserve{"$schema_obj_name.$name"};
437	}
438	else {
439	++$unreserve{"$name (table name)"};
440	}
441
442	my $unreserve = sprintf '%s_', $name;
443	return $unreserve.$suffix;
444	}
445
446	1;
447
448	# -------------------------------------------------------------------
449
450	=pod
451
452	=head1 SEE ALSO
453
454	SQL::Translator.
455
456	=head1 AUTHORS
457
458	Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
459	Sybase producer, I just tweaked it for SQLServer. Thanks.
460
461	=cut