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

=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

    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 = ($name ? unreserve($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;

    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
44659089	3	# -------------------------------------------------------------------
	4	# Copyright (C) 2002-2009 SQLFairy Authors
	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
7a0ceaa1	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.
e2fb9ad3	51	* Triggers, Procedures and Views DO NOT WORK
7a0ceaa1	52
	53	=cut
	54
	55	use strict;
da06ac74	56	use vars qw[ $DEBUG $WARN $VERSION ];
11ad2df9	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',
028386aa	81	#serial => 'numeric',
7a0ceaa1	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[
028386aa	89	ALL ANALYSE ANALYZE AND ANY AS ASC
7a0ceaa1	90	BETWEEN BINARY BOTH
7a0ceaa1	91	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
028386aa	92	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
7a0ceaa1	93	DEFAULT DEFERRABLE DESC DISTINCT DO
7a0ceaa1	94	ELSE END EXCEPT
028386aa	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
7a0ceaa1	99	NATURAL NEW NOT NOTNULL NULL
7a0ceaa1	100	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
028386aa	101	PRIMARY PUBLIC REFERENCES RIGHT
028386aa	102	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
7a0ceaa1	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 %global_names;
7a0ceaa1	111
	112	=pod
	113
	114	=head1 SQLServer Create Table Syntax
	115
	116	TODO
	117
	118	=cut
	119
	120	# -------------------------------------------------------------------
	121	sub produce {
	122	my $translator = shift;
	123	$DEBUG = $translator->debug;
	124	$WARN = $translator->show_warnings;
	125	my $no_comments = $translator->no_comments;
	126	my $add_drop_table = $translator->add_drop_table;
	127	my $schema = $translator->schema;
	128
e2fb9ad3	129	%global_names = (); #reset
e2fb9ad3	130
7a0ceaa1	131	my $output;
	132	$output .= header_comment."\n" unless ($no_comments);
	133
	134	# Generate the DROP statements. We do this in one block here as if we
	135	# have fkeys we need to drop in the correct order otherwise they will fail
	136	# due to the dependancies the fkeys setup. (There is no way to turn off
	137	# fkey checking while we sort the schema like MySQL's set
	138	# foreign_key_checks=0)
	139	# We assume the tables are in the correct order to set them up as you need
	140	# to have created a table to fkey to it. So the reverse order should drop
	141	# them properly, fingers crossed...
	142	if ($add_drop_table) {
	143	$output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
	144	foreach my $table (
	145	sort { $b->order <=> $a->order } $schema->get_tables
	146	) {
	147	my $name = unreserve($table->name);
	148	$output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
	149	}
	150	}
	151
	152	# Generate the CREATE sql
f9a5ee79	153
	154	my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
	155
7a0ceaa1	156	for my $table ( $schema->get_tables ) {
7a0ceaa1	157	my $table_name = $table->name or next;
7a0ceaa1	158	my $table_name_ur = unreserve($table_name) \|\| '';
	159
	160	my ( @comments, @field_defs, @index_defs, @constraint_defs );
	161
	162	push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
	163	unless $no_comments;
	164
	165	push @comments, map { "-- $_" } $table->comments;
	166
	167	#
	168	# Fields
	169	#
	170	my %field_name_scope;
	171	for my $field ( $table->get_fields ) {
e2fb9ad3	172	my $field_name = $field->name;
7a0ceaa1	173	my $field_name_ur = unreserve( $field_name, $table_name );
	174	my $field_def = qq["$field_name_ur"];
	175	$field_def =~ s/\"//g;
	176	if ( $field_def =~ /identity/ ){
	177	$field_def =~ s/identity/pidentity/;
	178	}
	179
	180	#
	181	# Datatype
	182	#
	183	my $data_type = lc $field->data_type;
	184	my $orig_data_type = $data_type;
	185	my %extra = $field->extra;
	186	my $list = $extra{'list'} \|\| [];
	187	# \todo deal with embedded quotes
	188	my $commalist = join( ', ', map { qq['$_'] } @$list );
7a0ceaa1	189
7a0ceaa1	190	if ( $data_type eq 'enum' ) {
e2fb9ad3	191	my $check_name = mk_name( $field_name . '_chk' );
7a0ceaa1	192	push @constraint_defs,
e2fb9ad3	193	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
7a0ceaa1	194	$data_type .= 'character varying';
	195	}
	196	elsif ( $data_type eq 'set' ) {
	197	$data_type .= 'character varying';
	198	}
f9a5ee79	199	elsif ( grep { $data_type eq $_ } qw/bytea blob clob/ ) {
	200	$data_type = 'varbinary';
	201	}
7a0ceaa1	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
7a0ceaa1	253	#
06baeb21	254	SQL::Translator::Producer->_apply_default_value(
	255	$field,
	256	\$field_def,
	257	[
	258	'NULL' => \'NULL',
	259	],
	260	);
bc8e2aa1	261
028386aa	262	push @field_defs, $field_def;
7a0ceaa1	263	}
	264
	265	#
	266	# Constraint Declarations
	267	#
	268	my @constraint_decs = ();
7a0ceaa1	269	for my $constraint ( $table->get_constraints ) {
	270	my $name = $constraint->name \|\| '';
	271	# Make sure we get a unique name
7a0ceaa1	272	my $type = $constraint->type \|\| NORMAL;
	273	my @fields = map { unreserve( $_, $table_name ) }
	274	$constraint->fields;
	275	my @rfields = map { unreserve( $_, $table_name ) }
	276	$constraint->reference_fields;
	277	next unless @fields;
	278
5bac76bc	279	my $c_def;
f9a5ee79	280	if ( $type eq FOREIGN_KEY ) {
e2fb9ad3	281	$name \|\|= mk_name( $table_name . '_fk' );
5bac76bc	282	my $on_delete = uc ($constraint->on_delete \|\| '');
	283	my $on_update = uc ($constraint->on_update \|\| '');
	284
	285	# The default implicit constraint action in MSSQL is RESTRICT
	286	# but you can not specify it explicitly. Go figure :)
	287	for ($on_delete, $on_update) {
	288	undef $_ if $_ eq 'RESTRICT'
	289	}
	290
028386aa	291	$c_def =
f9a5ee79	292	"ALTER TABLE $table_name ADD CONSTRAINT $name FOREIGN KEY".
7a0ceaa1	293	' (' . join( ', ', @fields ) . ') REFERENCES '.
7a0ceaa1	294	$constraint->reference_table.
f9a5ee79	295	' (' . join( ', ', @rfields ) . ')'
	296	;
	297
5bac76bc	298	if ( $on_delete && $on_delete ne "NO ACTION") {
	299	$c_def .= " ON DELETE $on_delete";
	300	}
	301	if ( $on_update && $on_update ne "NO ACTION") {
	302	$c_def .= " ON UPDATE $on_update";
	303	}
f9a5ee79	304
	305	$c_def .= ";";
	306
	307	push @foreign_constraints, $c_def;
	308	next;
	309	}
	310
	311
	312	if ( $type eq PRIMARY_KEY ) {
028386aa	313	$name = ($name ? unreserve($name) : mk_name( $table_name . '_pk' ));
028386aa	314	$c_def =
f9a5ee79	315	"CONSTRAINT $name PRIMARY KEY ".
f9a5ee79	316	'(' . join( ', ', @fields ) . ')';
7a0ceaa1	317	}
7a0ceaa1	318	elsif ( $type eq UNIQUE ) {
e2fb9ad3	319	$name \|\|= mk_name( $table_name . '_uc' );
028386aa	320	$c_def =
7a0ceaa1	321	"CONSTRAINT $name UNIQUE " .
	322	'(' . join( ', ', @fields ) . ')';
	323	}
04a180d6	324	push @constraint_defs, $c_def;
7a0ceaa1	325	}
	326
	327	#
	328	# Indices
	329	#
	330	for my $index ( $table->get_indices ) {
e2fb9ad3	331	my $idx_name = $index->name \|\| mk_name($table_name . '_idx');
7a0ceaa1	332	push @index_defs,
	333	"CREATE INDEX $idx_name ON $table_name (".
	334	join( ', ', $index->fields ) . ");";
	335	}
	336
	337	my $create_statement = "";
	338	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
028386aa	339	join( ",\n",
7a0ceaa1	340	map { " $_" } @field_defs, @constraint_defs
	341	).
	342	"\n);"
	343	;
	344
	345	$output .= join( "\n\n",
	346	@comments,
	347	$create_statement,
	348	@index_defs,
7a0ceaa1	349	);
	350	}
	351
f9a5ee79	352	# Add FK constraints
	353	$output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
	354
e2fb9ad3	355	# create view/procedure are NOT prepended to the input $sql, needs
	356	# to be filled in with the proper syntax
	357
6fac033a	358	=pod
e2fb9ad3	359
7a0ceaa1	360	# Text of view is already a 'create view' statement so no need to
	361	# be fancy
	362	foreach ( $schema->get_views ) {
	363	my $name = $_->name();
	364	$output .= "\n\n";
5c5997ef	365	$output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
3e0bcbfd	366	my $text = $_->sql();
e2fb9ad3	367	$text =~ s/\r//g;
5bb0a4ee	368	$output .= "$text\nGO\n";
7a0ceaa1	369	}
	370
	371	# Text of procedure already has the 'create procedure' stuff
	372	# so there is no need to do anything fancy. However, we should
	373	# think about doing fancy stuff with granting permissions and
	374	# so on.
	375	foreach ( $schema->get_procedures ) {
	376	my $name = $_->name();
	377	$output .= "\n\n";
5c5997ef	378	$output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
3e0bcbfd	379	my $text = $_->sql();
028386aa	380	$text =~ s/\r//g;
5bb0a4ee	381	$output .= "$text\nGO\n";
7a0ceaa1	382	}
e2fb9ad3	383	=cut
7a0ceaa1	384
	385	return $output;
	386	}
	387
	388	# -------------------------------------------------------------------
	389	sub mk_name {
e2fb9ad3	390	my ($name, $scope, $critical) = @_;
7a0ceaa1	391
	392	$scope \|\|= \%global_names;
	393	if ( my $prev = $scope->{ $name } ) {
	394	my $name_orig = $name;
	395	$name .= sprintf( "%02d", ++$prev );
028386aa	396	substr($name, $max_id_length - 3) = "00"
7a0ceaa1	397	if length( $name ) > $max_id_length;
	398
	399	warn "The name '$name_orig' has been changed to ",
	400	"'$name' to make it unique.\n" if $WARN;
	401
	402	$scope->{ $name_orig }++;
	403	}
028386aa	404	$name = substr( $name, 0, $max_id_length )
7a0ceaa1	405	if ((length( $name ) > $max_id_length) && $critical);
	406	$scope->{ $name }++;
	407	return $name;
	408	}
	409
	410	# -------------------------------------------------------------------
	411	sub unreserve {
	412	my $name = shift \|\| '';
	413	my $schema_obj_name = shift \|\| '';
	414	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	415
	416	# also trap fields that don't begin with a letter
028386aa	417	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
7a0ceaa1	418
7a0ceaa1	419	my $unreserve = sprintf '%s_', $name;
	420	return $unreserve.$suffix;
	421	}
	422
	423	1;
	424
	425	# -------------------------------------------------------------------
	426
	427	=pod
	428
	429	=head1 SEE ALSO
	430
	431	SQL::Translator.
	432
	433	=head1 AUTHORS
	434
	435	Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
	436	Sybase producer, I just tweaked it for SQLServer. Thanks.
	437
	438	=cut