[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 havn't been tested at all.

=cut

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

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

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	# -------------------------------------------------------------------
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.
	51	* Triggers, Procedures and Views havn't been tested at all.
	52
	53	=cut
	54
	55	use strict;
da06ac74	56	use vars qw[ $DEBUG $WARN $VERSION ];
4ab3763d	57	$VERSION = '1.59';
7a0ceaa1	58	$DEBUG = 1 unless defined $DEBUG;
	59
	60	use Data::Dumper;
	61	use SQL::Translator::Schema::Constants;
	62	use SQL::Translator::Utils qw(debug header_comment);
	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 %used_identifiers = ();
	111	my %global_names;
	112	my %unreserve;
	113	my %truncated;
	114
	115	=pod
	116
	117	=head1 SQLServer Create Table Syntax
	118
	119	TODO
	120
	121	=cut
	122
	123	# -------------------------------------------------------------------
	124	sub produce {
	125	my $translator = shift;
	126	$DEBUG = $translator->debug;
	127	$WARN = $translator->show_warnings;
	128	my $no_comments = $translator->no_comments;
	129	my $add_drop_table = $translator->add_drop_table;
	130	my $schema = $translator->schema;
	131
	132	my $output;
	133	$output .= header_comment."\n" unless ($no_comments);
	134
	135	# Generate the DROP statements. We do this in one block here as if we
	136	# have fkeys we need to drop in the correct order otherwise they will fail
	137	# due to the dependancies the fkeys setup. (There is no way to turn off
	138	# fkey checking while we sort the schema like MySQL's set
	139	# foreign_key_checks=0)
	140	# We assume the tables are in the correct order to set them up as you need
	141	# to have created a table to fkey to it. So the reverse order should drop
	142	# them properly, fingers crossed...
	143	if ($add_drop_table) {
	144	$output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
	145	foreach my $table (
	146	sort { $b->order <=> $a->order } $schema->get_tables
	147	) {
	148	my $name = unreserve($table->name);
	149	$output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
	150	}
	151	}
	152
	153	# Generate the CREATE sql
	154	for my $table ( $schema->get_tables ) {
	155	my $table_name = $table->name or next;
	156	$table_name = mk_name( $table_name, '', undef, 1 );
	157	my $table_name_ur = unreserve($table_name) \|\| '';
	158
	159	my ( @comments, @field_defs, @index_defs, @constraint_defs );
	160
	161	push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
	162	unless $no_comments;
	163
	164	push @comments, map { "-- $_" } $table->comments;
	165
	166	#
	167	# Fields
	168	#
	169	my %field_name_scope;
	170	for my $field ( $table->get_fields ) {
	171	my $field_name = mk_name(
	172	$field->name, '', \%field_name_scope, undef,1
	173	);
174	my $field_name_ur = unreserve( $field_name, $table_name );
175	my $field_def = qq["$field_name_ur"];
176	$field_def =~ s/\"//g;
177	if ( $field_def =~ /identity/ ){
178	$field_def =~ s/identity/pidentity/;
179	}
180
181	#
182	# Datatype
183	#
184	my $data_type = lc $field->data_type;
185	my $orig_data_type = $data_type;
186	my %extra = $field->extra;
187	my $list = $extra{'list'} \|\| [];
188	# \todo deal with embedded quotes
189	my $commalist = join( ', ', map { qq['$_'] } @$list );
7a0ceaa1	190
	191	if ( $data_type eq 'enum' ) {
	192	my $check_name = mk_name(
	193	$table_name.'_'.$field_name, 'chk' ,undef, 1
	194	);
	195	push @constraint_defs,
	196	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
	197	$data_type .= 'character varying';
	198	}
	199	elsif ( $data_type eq 'set' ) {
	200	$data_type .= 'character varying';
	201	}
	202	else {
	203	if ( defined $translate{ $data_type } ) {
	204	$data_type = $translate{ $data_type };
	205	}
	206	else {
	207	warn "Unknown datatype: $data_type ",
	208	"($table_name.$field_name)\n" if $WARN;
	209	}
	210	}
	211
	212	my $size = $field->size;
	213	if ( grep $_ eq $data_type, @no_size) {
	214	# SQLServer doesn't seem to like sizes on some datatypes
	215	$size = undef;
	216	}
	217	elsif ( !$size ) {
	218	if ( $data_type =~ /numeric/ ) {
	219	$size = '9,0';
	220	}
	221	elsif ( $orig_data_type eq 'text' ) {
	222	#interpret text fields as long varchars
	223	$size = '255';
	224	}
	225	elsif (
	226	$data_type eq 'varchar' &&
	227	$orig_data_type eq 'boolean'
	228	) {
	229	$size = '6';
	230	}
	231	elsif ( $data_type eq 'varchar' ) {
	232	$size = '255';
	233	}
	234	}
	235
	236	$field_def .= " $data_type";
	237	$field_def .= "($size)" if $size;
	238
	239	$field_def .= ' IDENTITY' if $field->is_auto_increment;
	240
	241	#
1426be03	242	# Not null constraint
	243	#
	244	unless ( $field->is_nullable ) {
	245	$field_def .= ' NOT NULL';
	246	}
	247	else {
	248	$field_def .= ' NULL' if $data_type ne 'bit';
	249	}
1426be03	250
1426be03	251	#
7a0ceaa1	252	# Default value
	253	#
	254	my $default = $field->default_value;
	255	if ( defined $default ) {
bc8e2aa1	256	SQL::Translator::Producer->_apply_default_value(
	257	\$field_def,
	258	$default,
	259	[
	260	'NULL' => \'NULL',
	261	],
7a0ceaa1	262	);
7a0ceaa1	263	}
bc8e2aa1	264
a7763b79	265	push @field_defs, $field_def;
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
04a180d6	284	my $c_def;
7a0ceaa1	285	if ( $type eq PRIMARY_KEY ) {
7a0ceaa1	286	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
04a180d6	287	$c_def =
7a0ceaa1	288	"CONSTRAINT $name PRIMARY KEY ".
	289	'(' . join( ', ', @fields ) . ')';
	290	}
	291	elsif ( $type eq FOREIGN_KEY ) {
	292	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	293	#$name = mk_name( ($name \|\| $table_name), 'fk', undef,1 );
04a180d6	294	$c_def =
7a0ceaa1	295	"CONSTRAINT $name FOREIGN KEY".
	296	' (' . join( ', ', @fields ) . ') REFERENCES '.
	297	$constraint->reference_table.
	298	' (' . join( ', ', @rfields ) . ')';
04a180d6	299	my $on_delete = $constraint->on_delete;
	300	if ( defined $on_delete && $on_delete ne "NO ACTION") {
	301	$c_def .= " ON DELETE $on_delete";
	302	}
	303	my $on_update = $constraint->on_update;
	304	if ( defined $on_update && $on_update ne "NO ACTION") {
	305	$c_def .= " ON UPDATE $on_update";
	306	}
7a0ceaa1	307	}
	308	elsif ( $type eq UNIQUE ) {
	309	$name \|\|= mk_name(
	310	$table_name,
	311	$name \|\| ++$c_name_default,undef, 1
	312	);
04a180d6	313	$c_def =
7a0ceaa1	314	"CONSTRAINT $name UNIQUE " .
	315	'(' . join( ', ', @fields ) . ')';
	316	}
04a180d6	317	push @constraint_defs, $c_def;
7a0ceaa1	318	}
	319
	320	#
	321	# Indices
	322	#
	323	for my $index ( $table->get_indices ) {
	324	my $idx_name = $index->name \|\| mk_name($table_name,'idx',undef,1);
	325	push @index_defs,
	326	"CREATE INDEX $idx_name ON $table_name (".
	327	join( ', ', $index->fields ) . ");";
	328	}
	329
	330	my $create_statement = "";
	331	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
	332	join( ",\n",
	333	map { " $_" } @field_defs, @constraint_defs
	334	).
	335	"\n);"
	336	;
	337
	338	$output .= join( "\n\n",
	339	@comments,
	340	$create_statement,
	341	@index_defs,
	342	''
	343	);
	344	}
	345
	346	# Text of view is already a 'create view' statement so no need to
	347	# be fancy
	348	foreach ( $schema->get_views ) {
	349	my $name = $_->name();
	350	$output .= "\n\n";
5c5997ef	351	$output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
3e0bcbfd	352	my $text = $_->sql();
3e0bcbfd	353	$text =~ s/\r//g;
5bb0a4ee	354	$output .= "$text\nGO\n";
7a0ceaa1	355	}
	356
	357	# Text of procedure already has the 'create procedure' stuff
	358	# so there is no need to do anything fancy. However, we should
	359	# think about doing fancy stuff with granting permissions and
	360	# so on.
	361	foreach ( $schema->get_procedures ) {
	362	my $name = $_->name();
	363	$output .= "\n\n";
5c5997ef	364	$output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
3e0bcbfd	365	my $text = $_->sql();
3e0bcbfd	366	$text =~ s/\r//g;
5bb0a4ee	367	$output .= "$text\nGO\n";
7a0ceaa1	368	}
	369
	370	# Warn out how we messed with the names.
	371	if ( $WARN ) {
	372	if ( %truncated ) {
	373	warn "Truncated " . keys( %truncated ) . " names:\n";
	374	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	375	}
	376	if ( %unreserve ) {
	377	warn "Encounted " . keys( %unreserve ) .
	378	" unsafe names in schema (reserved or invalid):\n";
	379	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	380	}
	381	}
	382
	383	return $output;
	384	}
	385
	386	# -------------------------------------------------------------------
	387	sub mk_name {
	388	my $basename = shift \|\| '';
	389	my $type = shift \|\| '';
	390	my $scope = shift \|\| '';
	391	my $critical = shift \|\| '';
	392	my $basename_orig = $basename;
	393	my $max_name = $type
	394	? $max_id_length - (length($type) + 1)
	395	: $max_id_length;
	396	$basename = substr( $basename, 0, $max_name )
	397	if length( $basename ) > $max_name;
	398	my $name = $type ? "${type}_$basename" : $basename;
	399
	400	if ( $basename ne $basename_orig and $critical ) {
	401	my $show_type = $type ? "+'$type'" : "";
	402	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	403	"character limit to make '$name'\n" if $WARN;
	404	$truncated{ $basename_orig } = $name;
	405	}
	406
	407	$scope \|\|= \%global_names;
	408	if ( my $prev = $scope->{ $name } ) {
	409	my $name_orig = $name;
	410	$name .= sprintf( "%02d", ++$prev );
	411	substr($name, $max_id_length - 3) = "00"
	412	if length( $name ) > $max_id_length;
	413
	414	warn "The name '$name_orig' has been changed to ",
	415	"'$name' to make it unique.\n" if $WARN;
	416
	417	$scope->{ $name_orig }++;
	418	}
	419	$name = substr( $name, 0, $max_id_length )
	420	if ((length( $name ) > $max_id_length) && $critical);
	421	$scope->{ $name }++;
	422	return $name;
	423	}
	424
	425	# -------------------------------------------------------------------
	426	sub unreserve {
	427	my $name = shift \|\| '';
	428	my $schema_obj_name = shift \|\| '';
	429	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	430
	431	# also trap fields that don't begin with a letter
432	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
433
434	if ( $schema_obj_name ) {
435	++$unreserve{"$schema_obj_name.$name"};
436	}
437	else {
438	++$unreserve{"$name (table name)"};
439	}
440
441	my $unreserve = sprintf '%s_', $name;
442	return $unreserve.$suffix;
443	}
444
445	1;
446
447	# -------------------------------------------------------------------
448
449	=pod
450
451	=head1 SEE ALSO
452
453	SQL::Translator.
454
455	=head1 AUTHORS
456
457	Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
458	Sybase producer, I just tweaked it for SQLServer. Thanks.
459
460	=cut