1 package SQL::Translator::Producer::SQLServer;
3 # -------------------------------------------------------------------
4 # $Id: SQLServer.pm 1440 2009-01-17 16:31:57Z jawnsy $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-2009 SQLFairy Authors
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.
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.
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
21 # -------------------------------------------------------------------
25 SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator
31 my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
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 ;-)
39 =head1 Extra Attributes
45 List of values for an enum field.
51 * !! Write some tests !!
52 * Reserved words list needs updating to SQLServer.
53 * Triggers, Procedures and Views havn't been tested at all.
58 use vars qw[ $DEBUG $WARN ];
59 $DEBUG = 1 unless defined $DEBUG;
62 use SQL::Translator::Schema::Constants;
63 use SQL::Translator::Utils qw(debug header_comment);
69 #integer => 'numeric',
73 #varchar => 'varchar',
74 #varchar2 => 'varchar',
75 #timestamp => 'datetime',
77 #real => 'double precision',
80 #tinyint => 'smallint',
81 #float => 'double precision',
83 #boolean => 'varchar',
88 # TODO - This is still the Sybase list!
89 my %reserved = map { $_, 1 } qw[
90 ALL ANALYSE ANALYZE AND ANY AS ASC
92 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
93 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
94 DEFAULT DEFERRABLE DESC DISTINCT DO
96 FALSE FOR FOREIGN FREEZE FROM FULL
98 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
99 JOIN LEADING LEFT LIKE LIMIT
100 NATURAL NEW NOT NOTNULL NULL
101 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
102 PRIMARY PUBLIC REFERENCES RIGHT
103 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
104 UNION UNIQUE USER USING VERBOSE WHEN WHERE
107 # If these datatypes have size appended the sql fails.
108 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
110 my $max_id_length = 128;
111 my %used_identifiers = ();
118 =head1 SQLServer Create Table Syntax
124 # -------------------------------------------------------------------
126 my $translator = shift;
127 $DEBUG = $translator->debug;
128 $WARN = $translator->show_warnings;
129 my $no_comments = $translator->no_comments;
130 my $add_drop_table = $translator->add_drop_table;
131 my $schema = $translator->schema;
134 $output .= header_comment."\n" unless ($no_comments);
136 # Generate the DROP statements. We do this in one block here as if we
137 # have fkeys we need to drop in the correct order otherwise they will fail
138 # due to the dependancies the fkeys setup. (There is no way to turn off
139 # fkey checking while we sort the schema like MySQL's set
140 # foreign_key_checks=0)
141 # We assume the tables are in the correct order to set them up as you need
142 # to have created a table to fkey to it. So the reverse order should drop
143 # them properly, fingers crossed...
144 if ($add_drop_table) {
145 $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
147 sort { $b->order <=> $a->order } $schema->get_tables
149 my $name = unreserve($table->name);
150 $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
154 # Generate the CREATE sql
155 for my $table ( $schema->get_tables ) {
156 my $table_name = $table->name or next;
157 $table_name = mk_name( $table_name, '', undef, 1 );
158 my $table_name_ur = unreserve($table_name) || '';
160 my ( @comments, @field_defs, @index_defs, @constraint_defs );
162 push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
165 push @comments, map { "-- $_" } $table->comments;
170 my %field_name_scope;
171 for my $field ( $table->get_fields ) {
172 my $field_name = mk_name(
173 $field->name, '', \%field_name_scope, undef,1
175 my $field_name_ur = unreserve( $field_name, $table_name );
176 my $field_def = qq["$field_name_ur"];
177 $field_def =~ s/\"//g;
178 if ( $field_def =~ /identity/ ){
179 $field_def =~ s/identity/pidentity/;
185 my $data_type = lc $field->data_type;
186 my $orig_data_type = $data_type;
187 my %extra = $field->extra;
188 my $list = $extra{'list'} || [];
189 # \todo deal with embedded quotes
190 my $commalist = join( ', ', map { qq['$_'] } @$list );
192 if ( $data_type eq 'enum' ) {
193 my $check_name = mk_name(
194 $table_name.'_'.$field_name, 'chk' ,undef, 1
196 push @constraint_defs,
197 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
198 $data_type .= 'character varying';
200 elsif ( $data_type eq 'set' ) {
201 $data_type .= 'character varying';
204 if ( defined $translate{ $data_type } ) {
205 $data_type = $translate{ $data_type };
208 warn "Unknown datatype: $data_type ",
209 "($table_name.$field_name)\n" if $WARN;
213 my $size = $field->size;
214 if ( grep $_ eq $data_type, @no_size) {
215 # SQLServer doesn't seem to like sizes on some datatypes
219 if ( $data_type =~ /numeric/ ) {
222 elsif ( $orig_data_type eq 'text' ) {
223 #interpret text fields as long varchars
227 $data_type eq 'varchar' &&
228 $orig_data_type eq 'boolean'
232 elsif ( $data_type eq 'varchar' ) {
237 $field_def .= " $data_type";
238 $field_def .= "($size)" if $size;
240 $field_def .= ' IDENTITY' if $field->is_auto_increment;
243 # Not null constraint
245 unless ( $field->is_nullable ) {
246 $field_def .= ' NOT NULL';
249 $field_def .= ' NULL' if $data_type ne 'bit';
255 my $default = $field->default_value;
256 if ( defined $default ) {
257 SQL::Translator::Producer->_apply_default_value(
266 push @field_defs, $field_def;
270 # Constraint Declarations
272 my @constraint_decs = ();
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 ) }
281 my @rfields = map { unreserve( $_, $table_name ) }
282 $constraint->reference_fields;
286 if ( $type eq PRIMARY_KEY ) {
287 $name ||= mk_name( $table_name, 'pk', undef,1 );
289 "CONSTRAINT $name PRIMARY KEY ".
290 '(' . join( ', ', @fields ) . ')';
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 );
296 "CONSTRAINT $name FOREIGN KEY".
297 ' (' . join( ', ', @fields ) . ') REFERENCES '.
298 $constraint->reference_table.
299 ' (' . join( ', ', @rfields ) . ')';
300 my $on_delete = $constraint->on_delete;
301 if ( defined $on_delete && $on_delete ne "NO ACTION") {
302 $c_def .= " ON DELETE $on_delete";
304 my $on_update = $constraint->on_update;
305 if ( defined $on_update && $on_update ne "NO ACTION") {
306 $c_def .= " ON UPDATE $on_update";
309 elsif ( $type eq UNIQUE ) {
312 $name || ++$c_name_default,undef, 1
315 "CONSTRAINT $name UNIQUE " .
316 '(' . join( ', ', @fields ) . ')';
318 push @constraint_defs, $c_def;
324 for my $index ( $table->get_indices ) {
325 my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
327 "CREATE INDEX $idx_name ON $table_name (".
328 join( ', ', $index->fields ) . ");";
331 my $create_statement = "";
332 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
334 map { " $_" } @field_defs, @constraint_defs
339 $output .= join( "\n\n",
347 # Text of view is already a 'create view' statement so no need to
349 foreach ( $schema->get_views ) {
350 my $name = $_->name();
352 $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
353 my $text = $_->sql();
355 $output .= "$text\nGO\n";
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
362 foreach ( $schema->get_procedures ) {
363 my $name = $_->name();
365 $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
366 my $text = $_->sql();
368 $output .= "$text\nGO\n";
371 # Warn out how we messed with the names.
374 warn "Truncated " . keys( %truncated ) . " names:\n";
375 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
378 warn "Encounted " . keys( %unreserve ) .
379 " unsafe names in schema (reserved or invalid):\n";
380 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
387 # -------------------------------------------------------------------
389 my $basename = shift || '';
390 my $type = shift || '';
391 my $scope = shift || '';
392 my $critical = shift || '';
393 my $basename_orig = $basename;
395 ? $max_id_length - (length($type) + 1)
397 $basename = substr( $basename, 0, $max_name )
398 if length( $basename ) > $max_name;
399 my $name = $type ? "${type}_$basename" : $basename;
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;
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;
415 warn "The name '$name_orig' has been changed to ",
416 "'$name' to make it unique.\n" if $WARN;
418 $scope->{ $name_orig }++;
420 $name = substr( $name, 0, $max_id_length )
421 if ((length( $name ) > $max_id_length) && $critical);
426 # -------------------------------------------------------------------
428 my $name = shift || '';
429 my $schema_obj_name = shift || '';
430 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
432 # also trap fields that don't begin with a letter
433 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
435 if ( $schema_obj_name ) {
436 ++$unreserve{"$schema_obj_name.$name"};
439 ++$unreserve{"$name (table name)"};
442 my $unreserve = sprintf '%s_', $name;
443 return $unreserve.$suffix;
448 # -------------------------------------------------------------------
458 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
459 Sybase producer, I just tweaked it for SQLServer. Thanks.