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

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

# -------------------------------------------------------------------
# $Id: SQLServer.pm,v 1.3 2005-07-11 20:12:02 duality72 Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002-4 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 $VERSION ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
$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 );
            my $seq_name;

            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';
            }
            push @field_defs, $field_def;

            #
            # Default value
            #
            my $default = $field->default_value;
            if ( defined $default ) {
                $field_def .= sprintf( ' DEFAULT %s',
                    ( $field->is_auto_increment && $seq_name )
                    ? qq[nextval('"$seq_name"'::text)] :
                    ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
                );
            }
        }

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

            if ( $type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk', undef,1 );
                push @constraint_defs,
                    "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 );
                push @constraint_defs, 
                    "CONSTRAINT $name FOREIGN KEY".
                    ' (' . join( ', ', @fields ) . ') REFERENCES '.
                    $constraint->reference_table.
                    ' (' . join( ', ', @rfields ) . ')';
            }
            elsif ( $type eq UNIQUE ) {
                $name ||= mk_name(
                    $table_name,
                    $name || ++$c_name_default,undef, 1
                );
                push @constraint_defs, 
                    "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
        }

        #
        # 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--" unless $no_comments;
        my $text = $_->sql();
		$text =~ s/\r//g;
        $output .= $text;
    }

    # 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--" unless $no_comments;
        my $text = $_->sql();
		$text =~ s/\r//g;
        $output .= $text;
    }

    # 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	# -------------------------------------------------------------------
1426be03	4	# $Id: SQLServer.pm,v 1.3 2005-07-11 20:12:02 duality72 Exp $
7a0ceaa1	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2002-4 SQLFairy Authors
	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;
	58	use vars qw[ $DEBUG $WARN $VERSION ];
1426be03	59	$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
7a0ceaa1	60	$DEBUG = 1 unless defined $DEBUG;
	61
	62	use Data::Dumper;
	63	use SQL::Translator::Schema::Constants;
	64	use SQL::Translator::Utils qw(debug header_comment);
	65
	66	my %translate = (
	67	date => 'datetime',
	68	'time' => 'datetime',
	69	# Sybase types
	70	#integer => 'numeric',
	71	#int => 'numeric',
	72	#number => 'numeric',
	73	#money => 'money',
	74	#varchar => 'varchar',
	75	#varchar2 => 'varchar',
	76	#timestamp => 'datetime',
	77	#text => 'varchar',
	78	#real => 'double precision',
	79	#comment => 'text',
	80	#bit => 'bit',
	81	#tinyint => 'smallint',
	82	#float => 'double precision',
	83	#serial => 'numeric',
	84	#boolean => 'varchar',
	85	#char => 'char',
	86	#long => 'varchar',
	87	);
	88
	89	# TODO - This is still the Sybase list!
	90	my %reserved = map { $_, 1 } qw[
	91	ALL ANALYSE ANALYZE AND ANY AS ASC
	92	BETWEEN BINARY BOTH
	93	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	94	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	95	DEFAULT DEFERRABLE DESC DISTINCT DO
	96	ELSE END EXCEPT
	97	FALSE FOR FOREIGN FREEZE FROM FULL
	98	GROUP HAVING
	99	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	100	JOIN LEADING LEFT LIKE LIMIT
	101	NATURAL NEW NOT NOTNULL NULL
	102	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	103	PRIMARY PUBLIC REFERENCES RIGHT
	104	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	105	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	106	];
	107
	108	# If these datatypes have size appended the sql fails.
3e0bcbfd	109	my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
7a0ceaa1	110
3e0bcbfd	111	my $max_id_length = 128;
7a0ceaa1	112	my %used_identifiers = ();
	113	my %global_names;
	114	my %unreserve;
	115	my %truncated;
	116
	117	=pod
	118
	119	=head1 SQLServer Create Table Syntax
	120
	121	TODO
	122
	123	=cut
	124
	125	# -------------------------------------------------------------------
	126	sub produce {
	127	my $translator = shift;
	128	$DEBUG = $translator->debug;
	129	$WARN = $translator->show_warnings;
	130	my $no_comments = $translator->no_comments;
	131	my $add_drop_table = $translator->add_drop_table;
	132	my $schema = $translator->schema;
	133
	134	my $output;
	135	$output .= header_comment."\n" unless ($no_comments);
	136
	137	# Generate the DROP statements. We do this in one block here as if we
	138	# have fkeys we need to drop in the correct order otherwise they will fail
	139	# due to the dependancies the fkeys setup. (There is no way to turn off
	140	# fkey checking while we sort the schema like MySQL's set
	141	# foreign_key_checks=0)
	142	# We assume the tables are in the correct order to set them up as you need
	143	# to have created a table to fkey to it. So the reverse order should drop
	144	# them properly, fingers crossed...
	145	if ($add_drop_table) {
	146	$output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
	147	foreach my $table (
	148	sort { $b->order <=> $a->order } $schema->get_tables
	149	) {
	150	my $name = unreserve($table->name);
	151	$output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
	152	}
	153	}
	154
	155	# Generate the CREATE sql
	156	for my $table ( $schema->get_tables ) {
	157	my $table_name = $table->name or next;
	158	$table_name = mk_name( $table_name, '', undef, 1 );
	159	my $table_name_ur = unreserve($table_name) \|\| '';
	160
	161	my ( @comments, @field_defs, @index_defs, @constraint_defs );
	162
	163	push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
	164	unless $no_comments;
	165
	166	push @comments, map { "-- $_" } $table->comments;
	167
	168	#
	169	# Fields
	170	#
	171	my %field_name_scope;
	172	for my $field ( $table->get_fields ) {
	173	my $field_name = mk_name(
	174	$field->name, '', \%field_name_scope, undef,1
	175	);
176	my $field_name_ur = unreserve( $field_name, $table_name );
177	my $field_def = qq["$field_name_ur"];
178	$field_def =~ s/\"//g;
179	if ( $field_def =~ /identity/ ){
180	$field_def =~ s/identity/pidentity/;
181	}
182
183	#
184	# Datatype
185	#
186	my $data_type = lc $field->data_type;
187	my $orig_data_type = $data_type;
188	my %extra = $field->extra;
189	my $list = $extra{'list'} \|\| [];
190	# \todo deal with embedded quotes
191	my $commalist = join( ', ', map { qq['$_'] } @$list );
192	my $seq_name;
193
194	if ( $data_type eq 'enum' ) {
195	my $check_name = mk_name(
196	$table_name.'_'.$field_name, 'chk' ,undef, 1
197	);
198	push @constraint_defs,
199	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
200	$data_type .= 'character varying';
201	}
202	elsif ( $data_type eq 'set' ) {
203	$data_type .= 'character varying';
204	}
205	else {
206	if ( defined $translate{ $data_type } ) {
207	$data_type = $translate{ $data_type };
208	}
209	else {
210	warn "Unknown datatype: $data_type ",
211	"($table_name.$field_name)\n" if $WARN;
212	}
213	}
214
215	my $size = $field->size;
216	if ( grep $_ eq $data_type, @no_size) {
217	# SQLServer doesn't seem to like sizes on some datatypes
218	$size = undef;
219	}
220	elsif ( !$size ) {
221	if ( $data_type =~ /numeric/ ) {
222	$size = '9,0';
223	}
224	elsif ( $orig_data_type eq 'text' ) {
225	#interpret text fields as long varchars
226	$size = '255';
227	}
228	elsif (
229	$data_type eq 'varchar' &&
230	$orig_data_type eq 'boolean'
231	) {
232	$size = '6';
233	}
234	elsif ( $data_type eq 'varchar' ) {
235	$size = '255';
236	}
237	}
238
239	$field_def .= " $data_type";
240	$field_def .= "($size)" if $size;
241
242	$field_def .= ' IDENTITY' if $field->is_auto_increment;
243
244	#
1426be03	245	# Not null constraint
	246	#
	247	unless ( $field->is_nullable ) {
	248	$field_def .= ' NOT NULL';
	249	}
	250	else {
	251	$field_def .= ' NULL' if $data_type ne 'bit';
	252	}
	253	push @field_defs, $field_def;
	254
	255	#
7a0ceaa1	256	# Default value
	257	#
	258	my $default = $field->default_value;
	259	if ( defined $default ) {
	260	$field_def .= sprintf( ' DEFAULT %s',
	261	( $field->is_auto_increment && $seq_name )
	262	? qq[nextval('"$seq_name"'::text)] :
	263	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
	264	);
	265	}
7a0ceaa1	266	}
	267
	268	#
	269	# Constraint Declarations
	270	#
	271	my @constraint_decs = ();
	272	my $c_name_default;
	273	for my $constraint ( $table->get_constraints ) {
	274	my $name = $constraint->name \|\| '';
	275	# Make sure we get a unique name
	276	$name = mk_name( $name, undef, undef, 1 ) if $name;
	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
	284	if ( $type eq PRIMARY_KEY ) {
	285	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
	286	push @constraint_defs,
	287	"CONSTRAINT $name PRIMARY KEY ".
	288	'(' . join( ', ', @fields ) . ')';
	289	}
	290	elsif ( $type eq FOREIGN_KEY ) {
	291	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	292	#$name = mk_name( ($name \|\| $table_name), 'fk', undef,1 );
	293	push @constraint_defs,
	294	"CONSTRAINT $name FOREIGN KEY".
	295	' (' . join( ', ', @fields ) . ') REFERENCES '.
	296	$constraint->reference_table.
	297	' (' . join( ', ', @rfields ) . ')';
	298	}
	299	elsif ( $type eq UNIQUE ) {
	300	$name \|\|= mk_name(
	301	$table_name,
	302	$name \|\| ++$c_name_default,undef, 1
	303	);
	304	push @constraint_defs,
	305	"CONSTRAINT $name UNIQUE " .
	306	'(' . join( ', ', @fields ) . ')';
	307	}
	308	}
	309
	310	#
	311	# Indices
	312	#
	313	for my $index ( $table->get_indices ) {
	314	my $idx_name = $index->name \|\| mk_name($table_name,'idx',undef,1);
	315	push @index_defs,
	316	"CREATE INDEX $idx_name ON $table_name (".
	317	join( ', ', $index->fields ) . ");";
	318	}
	319
	320	my $create_statement = "";
	321	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
	322	join( ",\n",
	323	map { " $_" } @field_defs, @constraint_defs
	324	).
	325	"\n);"
	326	;
	327
	328	$output .= join( "\n\n",
	329	@comments,
330	$create_statement,
331	@index_defs,
332	''
333	);
334	}
335
336	# Text of view is already a 'create view' statement so no need to
337	# be fancy
338	foreach ( $schema->get_views ) {
339	my $name = $_->name();
340	$output .= "\n\n";
341	$output .= "--\n-- View: $name\n--" unless $no_comments;
3e0bcbfd	342	my $text = $_->sql();
	343	$text =~ s/\r//g;
	344	$output .= $text;
7a0ceaa1	345	}
	346
	347	# Text of procedure already has the 'create procedure' stuff
	348	# so there is no need to do anything fancy. However, we should
	349	# think about doing fancy stuff with granting permissions and
	350	# so on.
	351	foreach ( $schema->get_procedures ) {
	352	my $name = $_->name();
	353	$output .= "\n\n";
	354	$output .= "--\n-- Procedure: $name\n--" unless $no_comments;
3e0bcbfd	355	my $text = $_->sql();
	356	$text =~ s/\r//g;
	357	$output .= $text;
7a0ceaa1	358	}
	359
	360	# Warn out how we messed with the names.
	361	if ( $WARN ) {
	362	if ( %truncated ) {
	363	warn "Truncated " . keys( %truncated ) . " names:\n";
	364	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	365	}
	366	if ( %unreserve ) {
	367	warn "Encounted " . keys( %unreserve ) .
	368	" unsafe names in schema (reserved or invalid):\n";
	369	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	370	}
	371	}
	372
	373	return $output;
	374	}
	375
	376	# -------------------------------------------------------------------
	377	sub mk_name {
	378	my $basename = shift \|\| '';
	379	my $type = shift \|\| '';
	380	my $scope = shift \|\| '';
	381	my $critical = shift \|\| '';
	382	my $basename_orig = $basename;
	383	my $max_name = $type
	384	? $max_id_length - (length($type) + 1)
	385	: $max_id_length;
	386	$basename = substr( $basename, 0, $max_name )
	387	if length( $basename ) > $max_name;
	388	my $name = $type ? "${type}_$basename" : $basename;
	389
	390	if ( $basename ne $basename_orig and $critical ) {
	391	my $show_type = $type ? "+'$type'" : "";
	392	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	393	"character limit to make '$name'\n" if $WARN;
	394	$truncated{ $basename_orig } = $name;
	395	}
	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