1 package SQL::Translator::Producer::SQLServer;
3 # -------------------------------------------------------------------
4 # Copyright (C) 2002-2009 SQLFairy Authors
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.
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.
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
19 # -------------------------------------------------------------------
23 SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator
29 my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
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 ;-)
37 =head1 Extra Attributes
43 List of values for an enum field.
49 * !! Write some tests !!
50 * Reserved words list needs updating to SQLServer.
51 * Triggers, Procedures and Views havn't been tested at all.
56 use vars qw[ $DEBUG $WARN $VERSION ];
58 $DEBUG = 1 unless defined $DEBUG;
61 use SQL::Translator::Schema::Constants;
62 use SQL::Translator::Utils qw(debug header_comment);
68 #integer => 'numeric',
72 #varchar => 'varchar',
73 #varchar2 => 'varchar',
74 #timestamp => 'datetime',
76 #real => 'double precision',
79 #tinyint => 'smallint',
80 #float => 'double precision',
82 #boolean => 'varchar',
87 # TODO - This is still the Sybase list!
88 my %reserved = map { $_, 1 } qw[
89 ALL ANALYSE ANALYZE AND ANY AS ASC
91 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
92 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
93 DEFAULT DEFERRABLE DESC DISTINCT DO
95 FALSE FOR FOREIGN FREEZE FROM FULL
97 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
98 JOIN LEADING LEFT LIKE LIMIT
99 NATURAL NEW NOT NOTNULL NULL
100 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
101 PRIMARY PUBLIC REFERENCES RIGHT
102 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
103 UNION UNIQUE USER USING VERBOSE WHEN WHERE
106 # If these datatypes have size appended the sql fails.
107 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
109 my $max_id_length = 128;
110 my %used_identifiers = ();
117 =head1 SQLServer Create Table Syntax
123 # -------------------------------------------------------------------
125 my $translator = shift;
126 $DEBUG = $translator->debug;
127 $WARN = $translator->show_warnings;
128 my $no_comments = $translator->no_comments;
129 my $add_drop_table = $translator->add_drop_table;
130 my $schema = $translator->schema;
133 $output .= header_comment."\n" unless ($no_comments);
135 # Generate the DROP statements. We do this in one block here as if we
136 # have fkeys we need to drop in the correct order otherwise they will fail
137 # due to the dependancies the fkeys setup. (There is no way to turn off
138 # fkey checking while we sort the schema like MySQL's set
139 # foreign_key_checks=0)
140 # We assume the tables are in the correct order to set them up as you need
141 # to have created a table to fkey to it. So the reverse order should drop
142 # them properly, fingers crossed...
143 if ($add_drop_table) {
144 $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
146 sort { $b->order <=> $a->order } $schema->get_tables
148 my $name = unreserve($table->name);
149 $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
153 # Generate the CREATE sql
154 for my $table ( $schema->get_tables ) {
155 my $table_name = $table->name or next;
156 $table_name = mk_name( $table_name, '', undef, 1 );
157 my $table_name_ur = unreserve($table_name) || '';
159 my ( @comments, @field_defs, @index_defs, @constraint_defs );
161 push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
164 push @comments, map { "-- $_" } $table->comments;
169 my %field_name_scope;
170 for my $field ( $table->get_fields ) {
171 my $field_name = mk_name(
172 $field->name, '', \%field_name_scope, undef,1
174 my $field_name_ur = unreserve( $field_name, $table_name );
175 my $field_def = qq["$field_name_ur"];
176 $field_def =~ s/\"//g;
177 if ( $field_def =~ /identity/ ){
178 $field_def =~ s/identity/pidentity/;
184 my $data_type = lc $field->data_type;
185 my $orig_data_type = $data_type;
186 my %extra = $field->extra;
187 my $list = $extra{'list'} || [];
188 # \todo deal with embedded quotes
189 my $commalist = join( ', ', map { qq['$_'] } @$list );
191 if ( $data_type eq 'enum' ) {
192 my $check_name = mk_name(
193 $table_name.'_'.$field_name, 'chk' ,undef, 1
195 push @constraint_defs,
196 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
197 $data_type .= 'character varying';
199 elsif ( $data_type eq 'set' ) {
200 $data_type .= 'character varying';
203 if ( defined $translate{ $data_type } ) {
204 $data_type = $translate{ $data_type };
207 warn "Unknown datatype: $data_type ",
208 "($table_name.$field_name)\n" if $WARN;
212 my $size = $field->size;
213 if ( grep $_ eq $data_type, @no_size) {
214 # SQLServer doesn't seem to like sizes on some datatypes
218 if ( $data_type =~ /numeric/ ) {
221 elsif ( $orig_data_type eq 'text' ) {
222 #interpret text fields as long varchars
226 $data_type eq 'varchar' &&
227 $orig_data_type eq 'boolean'
231 elsif ( $data_type eq 'varchar' ) {
236 $field_def .= " $data_type";
237 $field_def .= "($size)" if $size;
239 $field_def .= ' IDENTITY' if $field->is_auto_increment;
242 # Not null constraint
244 unless ( $field->is_nullable ) {
245 $field_def .= ' NOT NULL';
248 $field_def .= ' NULL' if $data_type ne 'bit';
254 my $default = $field->default_value;
255 if ( defined $default ) {
256 SQL::Translator::Producer->_apply_default_value(
265 push @field_defs, $field_def;
269 # Constraint Declarations
271 my @constraint_decs = ();
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 ) }
280 my @rfields = map { unreserve( $_, $table_name ) }
281 $constraint->reference_fields;
285 if ( $type eq PRIMARY_KEY ) {
286 $name ||= mk_name( $table_name, 'pk', undef,1 );
288 "CONSTRAINT $name PRIMARY KEY ".
289 '(' . join( ', ', @fields ) . ')';
291 elsif ( $type eq FOREIGN_KEY ) {
292 $name ||= mk_name( $table_name, 'fk', undef,1 );
293 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
295 "CONSTRAINT $name FOREIGN KEY".
296 ' (' . join( ', ', @fields ) . ') REFERENCES '.
297 $constraint->reference_table.
298 ' (' . join( ', ', @rfields ) . ')';
299 my $on_delete = $constraint->on_delete;
300 if ( defined $on_delete && $on_delete ne "NO ACTION") {
301 $c_def .= " ON DELETE $on_delete";
303 my $on_update = $constraint->on_update;
304 if ( defined $on_update && $on_update ne "NO ACTION") {
305 $c_def .= " ON UPDATE $on_update";
308 elsif ( $type eq UNIQUE ) {
311 $name || ++$c_name_default,undef, 1
314 "CONSTRAINT $name UNIQUE " .
315 '(' . join( ', ', @fields ) . ')';
317 push @constraint_defs, $c_def;
323 for my $index ( $table->get_indices ) {
324 my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
326 "CREATE INDEX $idx_name ON $table_name (".
327 join( ', ', $index->fields ) . ");";
330 my $create_statement = "";
331 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
333 map { " $_" } @field_defs, @constraint_defs
338 $output .= join( "\n\n",
346 # Text of view is already a 'create view' statement so no need to
348 foreach ( $schema->get_views ) {
349 my $name = $_->name();
351 $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
352 my $text = $_->sql();
354 $output .= "$text\nGO\n";
357 # Text of procedure already has the 'create procedure' stuff
358 # so there is no need to do anything fancy. However, we should
359 # think about doing fancy stuff with granting permissions and
361 foreach ( $schema->get_procedures ) {
362 my $name = $_->name();
364 $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
365 my $text = $_->sql();
367 $output .= "$text\nGO\n";
370 # Warn out how we messed with the names.
373 warn "Truncated " . keys( %truncated ) . " names:\n";
374 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
377 warn "Encounted " . keys( %unreserve ) .
378 " unsafe names in schema (reserved or invalid):\n";
379 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
386 # -------------------------------------------------------------------
388 my $basename = shift || '';
389 my $type = shift || '';
390 my $scope = shift || '';
391 my $critical = shift || '';
392 my $basename_orig = $basename;
394 ? $max_id_length - (length($type) + 1)
396 $basename = substr( $basename, 0, $max_name )
397 if length( $basename ) > $max_name;
398 my $name = $type ? "${type}_$basename" : $basename;
400 if ( $basename ne $basename_orig and $critical ) {
401 my $show_type = $type ? "+'$type'" : "";
402 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
403 "character limit to make '$name'\n" if $WARN;
404 $truncated{ $basename_orig } = $name;
407 $scope ||= \%global_names;
408 if ( my $prev = $scope->{ $name } ) {
409 my $name_orig = $name;
410 $name .= sprintf( "%02d", ++$prev );
411 substr($name, $max_id_length - 3) = "00"
412 if length( $name ) > $max_id_length;
414 warn "The name '$name_orig' has been changed to ",
415 "'$name' to make it unique.\n" if $WARN;
417 $scope->{ $name_orig }++;
419 $name = substr( $name, 0, $max_id_length )
420 if ((length( $name ) > $max_id_length) && $critical);
425 # -------------------------------------------------------------------
427 my $name = shift || '';
428 my $schema_obj_name = shift || '';
429 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
431 # also trap fields that don't begin with a letter
432 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
434 if ( $schema_obj_name ) {
435 ++$unreserve{"$schema_obj_name.$name"};
438 ++$unreserve{"$name (table name)"};
441 my $unreserve = sprintf '%s_', $name;
442 return $unreserve.$suffix;
447 # -------------------------------------------------------------------
457 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
458 Sybase producer, I just tweaked it for SQLServer. Thanks.