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

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

=head1 NAME

SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator

=head1 SYNOPSIS

  use SQL::Translator;

  my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
  $t->translate;

=head1 DESCRIPTION

B<WARNING>B This is still fairly early code, basically a hacked version of the
Sybase Producer (thanks Sam, Paul and Ken for doing the real work ;-)

=head1 Extra Attributes

=over 4

=item field.list

List of values for an enum field.

=back

=head1 TODO

 * !! Write some tests !!
 * Reserved words list needs updating to SQLServer.
 * Triggers, Procedures and Views DO NOT WORK

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = '1.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 %global_names;
my %unreserve;

=pod

=head1 SQLServer Create Table Syntax

TODO

=cut

# -------------------------------------------------------------------
sub produce {
    my $translator     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;

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

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

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

    # Generate the CREATE sql

    my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet

    for my $table ( $schema->get_tables ) {
        my $table_name    = $table->name or next;
        my $table_name_ur = unreserve($table_name) || '';

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

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

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

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

            #
            # Datatype
            #
            my $data_type      = lc $field->data_type;
            my $orig_data_type = $data_type;
            my %extra          = $field->extra;
            my $list           = $extra{'list'} || [];
            # \todo deal with embedded quotes
            my $commalist      = join( ', ', map { qq['$_'] } @$list );

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

            my $size = $field->size;
            if ( grep $_ eq $data_type, @no_size) {
            # SQLServer doesn't seem to like sizes on some datatypes
                $size = undef;
            }
            elsif ( !$size ) {
                if ( $data_type =~ /numeric/ ) {
                    $size = '9,0';
                }
                elsif ( $orig_data_type eq 'text' ) {
                    #interpret text fields as long varchars
                    $size = '255';
                }
                elsif (
                    $data_type eq 'varchar' &&
                    $orig_data_type eq 'boolean'
                ) {
                    $size = '6';
                }
                elsif ( $data_type eq 'varchar' ) {
                    $size = '255';
                }
            }

            $field_def .= " $data_type";
            $field_def .= "($size)" if $size;

            $field_def .= ' IDENTITY' if $field->is_auto_increment;

            #
            # Not null constraint
            #
            unless ( $field->is_nullable ) {
                $field_def .= ' NOT NULL';
            }
            else {
                $field_def .= ' NULL' if $data_type ne 'bit';
            }

            #
            # Default value
            #
            SQL::Translator::Producer->_apply_default_value(
              $field,
              \$field_def,
              [
                'NULL'       => \'NULL',
              ],
            );

            push @field_defs, $field_def;            
        }

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

            my $c_def;
            if ( $type eq FOREIGN_KEY ) {
                $name ||= mk_name( $table_name . '_fk' );
                my $on_delete = uc ($constraint->on_delete || '');
                my $on_update = uc ($constraint->on_update || '');

                # The default implicit constraint action in MSSQL is RESTRICT
                # but you can not specify it explicitly. Go figure :)
                for ($on_delete, $on_update) {
                  undef $_ if $_ eq 'RESTRICT'
                }

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

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

                $c_def .= ";";

                push @foreign_constraints, $c_def;
                next;
            }


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

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

        my $create_statement = "";
        $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
            join( ",\n", 
                map { "  $_" } @field_defs, @constraint_defs
            ).
            "\n);"
        ;

        $output .= join( "\n\n",
            @comments,
            $create_statement,
            @index_defs,
        );
    }

# Add FK constraints
    $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;

# create view/procedure are NOT prepended to the input $sql, needs
# to be filled in with the proper syntax

=pod

    # Text of view is already a 'create view' statement so no need to
    # be fancy
    foreach ( $schema->get_views ) {
        my $name = $_->name();
        $output .= "\n\n";
        $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
        my $text = $_->sql();
        $text =~ s/\r//g;
        $output .= "$text\nGO\n";
    }

    # Text of procedure already has the 'create procedure' stuff
    # so there is no need to do anything fancy. However, we should
    # think about doing fancy stuff with granting permissions and
    # so on.
    foreach ( $schema->get_procedures ) {
        my $name = $_->name();
        $output .= "\n\n";
        $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
        my $text = $_->sql();
		$text =~ s/\r//g;
        $output .= "$text\nGO\n";
    }
=cut

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my ($name, $scope, $critical) = @_;

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00" 
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to ",
             "'$name' to make it unique.\n" if $WARN;

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

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

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

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

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

1;

# -------------------------------------------------------------------

=pod

=head1 SEE ALSO

SQL::Translator.

=head1 AUTHORS

Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
Sybase producer, I just tweaked it for SQLServer. Thanks.

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