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

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

# -------------------------------------------------------------------
# $Id: SQLServer.pm,v 1.1 2005-01-13 21:30:04 grommit 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.1 $ =~ /(\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/int integer bigint text bit/;

my $max_id_length    = 30;
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;

            #
            # 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'"
                );
            }

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

            if ( $type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk', undef,1 );
                push @constraint_defs,
                    "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 );
                push @constraint_defs, 
                    "CONSTRAINT $name FOREIGN KEY".
                    ' (' . join( ', ', @fields ) . ') REFERENCES '.
                    $constraint->reference_table.
                    ' (' . join( ', ', @rfields ) . ')';
            }
            elsif ( $type eq UNIQUE ) {
                $name ||= mk_name(
                    $table_name,
                    $name || ++$c_name_default,undef, 1
                );
                push @constraint_defs, 
                    "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
        }

        #
        # 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;
        $output .= $_->sql();
    }

    # 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;
        $output .= $_->sql();
    }

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