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 DO NOT WORK
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;
115 =head1 SQLServer Create Table Syntax
121 # -------------------------------------------------------------------
123 my $translator = shift;
124 $DEBUG = $translator->debug;
125 $WARN = $translator->show_warnings;
126 my $no_comments = $translator->no_comments;
127 my $add_drop_table = $translator->add_drop_table;
128 my $schema = $translator->schema;
130 %global_names = (); #reset
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 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 = $field->name;
172 my $field_name_ur = unreserve( $field_name, $table_name );
173 my $field_def = qq["$field_name_ur"];
174 $field_def =~ s/\"//g;
175 if ( $field_def =~ /identity/ ){
176 $field_def =~ s/identity/pidentity/;
182 my $data_type = lc $field->data_type;
183 my $orig_data_type = $data_type;
184 my %extra = $field->extra;
185 my $list = $extra{'list'} || [];
186 # \todo deal with embedded quotes
187 my $commalist = join( ', ', map { qq['$_'] } @$list );
189 if ( $data_type eq 'enum' ) {
190 my $check_name = mk_name( $field_name . '_chk' );
191 push @constraint_defs,
192 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
193 $data_type .= 'character varying';
195 elsif ( $data_type eq 'set' ) {
196 $data_type .= 'character varying';
199 if ( defined $translate{ $data_type } ) {
200 $data_type = $translate{ $data_type };
203 warn "Unknown datatype: $data_type ",
204 "($table_name.$field_name)\n" if $WARN;
208 my $size = $field->size;
209 if ( grep $_ eq $data_type, @no_size) {
210 # SQLServer doesn't seem to like sizes on some datatypes
214 if ( $data_type =~ /numeric/ ) {
217 elsif ( $orig_data_type eq 'text' ) {
218 #interpret text fields as long varchars
222 $data_type eq 'varchar' &&
223 $orig_data_type eq 'boolean'
227 elsif ( $data_type eq 'varchar' ) {
232 $field_def .= " $data_type";
233 $field_def .= "($size)" if $size;
235 $field_def .= ' IDENTITY' if $field->is_auto_increment;
238 # Not null constraint
240 unless ( $field->is_nullable ) {
241 $field_def .= ' NOT NULL';
244 $field_def .= ' NULL' if $data_type ne 'bit';
250 my $default = $field->default_value;
251 if ( defined $default ) {
252 SQL::Translator::Producer->_apply_default_value(
261 push @field_defs, $field_def;
265 # Constraint Declarations
267 my @constraint_decs = ();
268 for my $constraint ( $table->get_constraints ) {
269 my $name = $constraint->name || '';
270 # Make sure we get a unique name
271 my $type = $constraint->type || NORMAL;
272 my @fields = map { unreserve( $_, $table_name ) }
274 my @rfields = map { unreserve( $_, $table_name ) }
275 $constraint->reference_fields;
279 if ( $type eq PRIMARY_KEY ) {
280 $name ||= mk_name( $table_name . '_pk' );
282 "CONSTRAINT $name PRIMARY KEY ".
283 '(' . join( ', ', @fields ) . ')';
285 elsif ( $type eq FOREIGN_KEY ) {
286 $name ||= mk_name( $table_name . '_fk' );
288 "CONSTRAINT $name FOREIGN KEY".
289 ' (' . join( ', ', @fields ) . ') REFERENCES '.
290 $constraint->reference_table.
291 ' (' . join( ', ', @rfields ) . ')';
292 my $on_delete = $constraint->on_delete;
293 if ( $on_delete && $on_delete ne "NO ACTION") {
294 $c_def .= " ON DELETE $on_delete";
296 my $on_update = $constraint->on_update;
297 if ( $on_update && $on_update ne "NO ACTION") {
298 $c_def .= " ON UPDATE $on_update";
301 elsif ( $type eq UNIQUE ) {
302 $name ||= mk_name( $table_name . '_uc' );
304 "CONSTRAINT $name UNIQUE " .
305 '(' . join( ', ', @fields ) . ')';
307 push @constraint_defs, $c_def;
313 for my $index ( $table->get_indices ) {
314 my $idx_name = $index->name || mk_name($table_name . '_idx');
316 "CREATE INDEX $idx_name ON $table_name (".
317 join( ', ', $index->fields ) . ");";
320 my $create_statement = "";
321 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
323 map { " $_" } @field_defs, @constraint_defs
328 $output .= join( "\n\n",
335 # create view/procedure are NOT prepended to the input $sql, needs
336 # to be filled in with the proper syntax
340 # Text of view is already a 'create view' statement so no need to
342 foreach ( $schema->get_views ) {
343 my $name = $_->name();
345 $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
346 my $text = $_->sql();
348 $output .= "$text\nGO\n";
351 # Text of procedure already has the 'create procedure' stuff
352 # so there is no need to do anything fancy. However, we should
353 # think about doing fancy stuff with granting permissions and
355 foreach ( $schema->get_procedures ) {
356 my $name = $_->name();
358 $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
359 my $text = $_->sql();
361 $output .= "$text\nGO\n";
368 # -------------------------------------------------------------------
370 my ($name, $scope, $critical) = @_;
372 $scope ||= \%global_names;
373 if ( my $prev = $scope->{ $name } ) {
374 my $name_orig = $name;
375 $name .= sprintf( "%02d", ++$prev );
376 substr($name, $max_id_length - 3) = "00"
377 if length( $name ) > $max_id_length;
379 warn "The name '$name_orig' has been changed to ",
380 "'$name' to make it unique.\n" if $WARN;
382 $scope->{ $name_orig }++;
384 $name = substr( $name, 0, $max_id_length )
385 if ((length( $name ) > $max_id_length) && $critical);
390 # -------------------------------------------------------------------
392 my $name = shift || '';
393 my $schema_obj_name = shift || '';
394 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
396 # also trap fields that don't begin with a letter
397 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
399 if ( $schema_obj_name ) {
400 ++$unreserve{"$schema_obj_name.$name"};
403 ++$unreserve{"$name (table name)"};
406 my $unreserve = sprintf '%s_', $name;
407 return $unreserve.$suffix;
412 # -------------------------------------------------------------------
422 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
423 Sybase producer, I just tweaked it for SQLServer. Thanks.