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

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

# -------------------------------------------------------------------
# $Id: SQLServer.pm,v 1.5 2006-05-05 16:41:26 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.5 $ =~ /(\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';
            }

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