1a0c294951b1780c49fb84b7df8070f8aa766c74
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / SQLServer.pm
1 package SQL::Translator::Producer::SQLServer;
2
3 # -------------------------------------------------------------------
4 # $Id: SQLServer.pm,v 1.7 2007-03-14 16:56:33 duality72 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.7 $ =~ /(\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/tinyint smallint int integer bigint text bit image datetime/;
110
111 my $max_id_length    = 128;
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             # 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             }
253
254             #
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             }
265             
266             push @field_defs, $field_def;            
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
285                         my $c_def;
286             if ( $type eq PRIMARY_KEY ) {
287                 $name ||= mk_name( $table_name, 'pk', undef,1 );
288                 $c_def = 
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 );
295                 $c_def = 
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";
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                  }
308             }
309             elsif ( $type eq UNIQUE ) {
310                 $name ||= mk_name(
311                     $table_name,
312                     $name || ++$c_name_default,undef, 1
313                 );
314                 $c_def = 
315                     "CONSTRAINT $name UNIQUE " .
316                     '(' . join( ', ', @fields ) . ')';
317             }
318             push @constraint_defs, $c_def;
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--\n\n" unless $no_comments;
353         my $text = $_->sql();
354                 $text =~ s/\r//g;
355         $output .= "$text\nGO\n";
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--\n\n" unless $no_comments;
366         my $text = $_->sql();
367                 $text =~ s/\r//g;
368         $output .= "$text\nGO\n";
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