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

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

# -------------------------------------------------------------------
# $Id$
# -------------------------------------------------------------------
# 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$ =~ /(\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 );

            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	# -------------------------------------------------------------------
821a0fde	4	# $Id$
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 ];
821a0fde	59	$VERSION = sprintf "%d.%02d", q$Revision$ =~ /(\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 );
7a0ceaa1	192
	193	if ( $data_type eq 'enum' ) {
	194	my $check_name = mk_name(
	195	$table_name.'_'.$field_name, 'chk' ,undef, 1
	196	);
	197	push @constraint_defs,
	198	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
	199	$data_type .= 'character varying';
	200	}
	201	elsif ( $data_type eq 'set' ) {
	202	$data_type .= 'character varying';
	203	}
	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 = ();
	274	my $c_name_default;
	275	for my $constraint ( $table->get_constraints ) {
	276	my $name = $constraint->name \|\| '';
	277	# Make sure we get a unique name
	278	$name = mk_name( $name, undef, undef, 1 ) if $name;
	279	my $type = $constraint->type \|\| NORMAL;
	280	my @fields = map { unreserve( $_, $table_name ) }
	281	$constraint->fields;
	282	my @rfields = map { unreserve( $_, $table_name ) }
	283	$constraint->reference_fields;
	284	next unless @fields;
	285
04a180d6	286	my $c_def;
7a0ceaa1	287	if ( $type eq PRIMARY_KEY ) {
7a0ceaa1	288	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
04a180d6	289	$c_def =
7a0ceaa1	290	"CONSTRAINT $name PRIMARY KEY ".
	291	'(' . join( ', ', @fields ) . ')';
	292	}
	293	elsif ( $type eq FOREIGN_KEY ) {
	294	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	295	#$name = mk_name( ($name \|\| $table_name), 'fk', undef,1 );
04a180d6	296	$c_def =
7a0ceaa1	297	"CONSTRAINT $name FOREIGN KEY".
	298	' (' . join( ', ', @fields ) . ') REFERENCES '.
	299	$constraint->reference_table.
	300	' (' . join( ', ', @rfields ) . ')';
04a180d6	301	my $on_delete = $constraint->on_delete;
	302	if ( defined $on_delete && $on_delete ne "NO ACTION") {
	303	$c_def .= " ON DELETE $on_delete";
	304	}
	305	my $on_update = $constraint->on_update;
	306	if ( defined $on_update && $on_update ne "NO ACTION") {
	307	$c_def .= " ON UPDATE $on_update";
	308	}
7a0ceaa1	309	}
	310	elsif ( $type eq UNIQUE ) {
	311	$name \|\|= mk_name(
	312	$table_name,
	313	$name \|\| ++$c_name_default,undef, 1
	314	);
04a180d6	315	$c_def =
7a0ceaa1	316	"CONSTRAINT $name UNIQUE " .
	317	'(' . join( ', ', @fields ) . ')';
	318	}
04a180d6	319	push @constraint_defs, $c_def;
7a0ceaa1	320	}
	321
	322	#
	323	# Indices
	324	#
	325	for my $index ( $table->get_indices ) {
	326	my $idx_name = $index->name \|\| mk_name($table_name,'idx',undef,1);
	327	push @index_defs,
	328	"CREATE INDEX $idx_name ON $table_name (".
	329	join( ', ', $index->fields ) . ");";
	330	}
	331
	332	my $create_statement = "";
	333	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
	334	join( ",\n",
	335	map { " $_" } @field_defs, @constraint_defs
	336	).
	337	"\n);"
	338	;
	339
	340	$output .= join( "\n\n",
	341	@comments,
	342	$create_statement,
	343	@index_defs,
	344	''
	345	);
	346	}
	347
	348	# Text of view is already a 'create view' statement so no need to
	349	# be fancy
	350	foreach ( $schema->get_views ) {
	351	my $name = $_->name();
	352	$output .= "\n\n";
5c5997ef	353	$output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
3e0bcbfd	354	my $text = $_->sql();
3e0bcbfd	355	$text =~ s/\r//g;
5bb0a4ee	356	$output .= "$text\nGO\n";
7a0ceaa1	357	}
	358
	359	# Text of procedure already has the 'create procedure' stuff
	360	# so there is no need to do anything fancy. However, we should
	361	# think about doing fancy stuff with granting permissions and
	362	# so on.
	363	foreach ( $schema->get_procedures ) {
	364	my $name = $_->name();
	365	$output .= "\n\n";
5c5997ef	366	$output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
3e0bcbfd	367	my $text = $_->sql();
3e0bcbfd	368	$text =~ s/\r//g;
5bb0a4ee	369	$output .= "$text\nGO\n";
7a0ceaa1	370	}
	371
	372	# Warn out how we messed with the names.
	373	if ( $WARN ) {
	374	if ( %truncated ) {
	375	warn "Truncated " . keys( %truncated ) . " names:\n";
	376	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	377	}
	378	if ( %unreserve ) {
	379	warn "Encounted " . keys( %unreserve ) .
	380	" unsafe names in schema (reserved or invalid):\n";
	381	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	382	}
	383	}
	384
	385	return $output;
	386	}
	387
	388	# -------------------------------------------------------------------
	389	sub mk_name {
	390	my $basename = shift \|\| '';
	391	my $type = shift \|\| '';
	392	my $scope = shift \|\| '';
	393	my $critical = shift \|\| '';
	394	my $basename_orig = $basename;
	395	my $max_name = $type
	396	? $max_id_length - (length($type) + 1)
	397	: $max_id_length;
	398	$basename = substr( $basename, 0, $max_name )
	399	if length( $basename ) > $max_name;
	400	my $name = $type ? "${type}_$basename" : $basename;
	401
	402	if ( $basename ne $basename_orig and $critical ) {
	403	my $show_type = $type ? "+'$type'" : "";
	404	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	405	"character limit to make '$name'\n" if $WARN;
	406	$truncated{ $basename_orig } = $name;
	407	}
	408
	409	$scope \|\|= \%global_names;
	410	if ( my $prev = $scope->{ $name } ) {
	411	my $name_orig = $name;
	412	$name .= sprintf( "%02d", ++$prev );
	413	substr($name, $max_id_length - 3) = "00"
	414	if length( $name ) > $max_id_length;
	415
	416	warn "The name '$name_orig' has been changed to ",
	417	"'$name' to make it unique.\n" if $WARN;
	418
	419	$scope->{ $name_orig }++;
	420	}
	421	$name = substr( $name, 0, $max_id_length )
	422	if ((length( $name ) > $max_id_length) && $critical);
	423	$scope->{ $name }++;
	424	return $name;
	425	}
	426
	427	# -------------------------------------------------------------------
	428	sub unreserve {
	429	my $name = shift \|\| '';
	430	my $schema_obj_name = shift \|\| '';
	431	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	432
	433	# also trap fields that don't begin with a letter
434	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
435
436	if ( $schema_obj_name ) {
437	++$unreserve{"$schema_obj_name.$name"};
438	}
439	else {
440	++$unreserve{"$name (table name)"};
441	}
442
443	my $unreserve = sprintf '%s_', $name;
444	return $unreserve.$suffix;
445	}
446
447	1;
448
449	# -------------------------------------------------------------------
450
451	=pod
452
453	=head1 SEE ALSO
454
455	SQL::Translator.
456
457	=head1 AUTHORS
458
459	Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
460	Sybase producer, I just tweaked it for SQLServer. Thanks.
461
462	=cut