1 package SQL::Translator::Producer::SQLServer;
3 # -------------------------------------------------------------------
4 # $Id: SQLServer.pm,v 1.3 2005-07-11 20:12:02 duality72 Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-4 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 $VERSION ];
59 $VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
60 $DEBUG = 1 unless defined $DEBUG;
63 use SQL::Translator::Schema::Constants;
64 use SQL::Translator::Utils qw(debug header_comment);
70 #integer => 'numeric',
74 #varchar => 'varchar',
75 #varchar2 => 'varchar',
76 #timestamp => 'datetime',
78 #real => 'double precision',
81 #tinyint => 'smallint',
82 #float => 'double precision',
84 #boolean => 'varchar',
89 # TODO - This is still the Sybase list!
90 my %reserved = map { $_, 1 } qw[
91 ALL ANALYSE ANALYZE AND ANY AS ASC
93 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
94 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
95 DEFAULT DEFERRABLE DESC DISTINCT DO
97 FALSE FOR FOREIGN FREEZE FROM FULL
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
108 # If these datatypes have size appended the sql fails.
109 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
111 my $max_id_length = 128;
112 my %used_identifiers = ();
119 =head1 SQLServer Create Table Syntax
125 # -------------------------------------------------------------------
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;
135 $output .= header_comment."\n" unless ($no_comments);
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;
148 sort { $b->order <=> $a->order } $schema->get_tables
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}
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) || '';
161 my ( @comments, @field_defs, @index_defs, @constraint_defs );
163 push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
166 push @comments, map { "-- $_" } $table->comments;
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
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/;
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 );
194 if ( $data_type eq 'enum' ) {
195 my $check_name = mk_name(
196 $table_name.'_'.$field_name, 'chk' ,undef, 1
198 push @constraint_defs,
199 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
200 $data_type .= 'character varying';
202 elsif ( $data_type eq 'set' ) {
203 $data_type .= 'character varying';
206 if ( defined $translate{ $data_type } ) {
207 $data_type = $translate{ $data_type };
210 warn "Unknown datatype: $data_type ",
211 "($table_name.$field_name)\n" if $WARN;
215 my $size = $field->size;
216 if ( grep $_ eq $data_type, @no_size) {
217 # SQLServer doesn't seem to like sizes on some datatypes
221 if ( $data_type =~ /numeric/ ) {
224 elsif ( $orig_data_type eq 'text' ) {
225 #interpret text fields as long varchars
229 $data_type eq 'varchar' &&
230 $orig_data_type eq 'boolean'
234 elsif ( $data_type eq 'varchar' ) {
239 $field_def .= " $data_type";
240 $field_def .= "($size)" if $size;
242 $field_def .= ' IDENTITY' if $field->is_auto_increment;
245 # Not null constraint
247 unless ( $field->is_nullable ) {
248 $field_def .= ' NOT NULL';
251 $field_def .= ' NULL' if $data_type ne 'bit';
253 push @field_defs, $field_def;
258 my $default = $field->default_value;
259 if ( defined $default ) {
260 $field_def .= sprintf( ' DEFAULT %s',
261 ( $field->is_auto_increment && $seq_name )
262 ? qq[nextval('"$seq_name"'::text)] :
263 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
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;
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 ) . ')';
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 ) . ')';
299 elsif ( $type eq UNIQUE ) {
302 $name || ++$c_name_default,undef, 1
304 push @constraint_defs,
305 "CONSTRAINT $name UNIQUE " .
306 '(' . join( ', ', @fields ) . ')';
313 for my $index ( $table->get_indices ) {
314 my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
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",
336 # Text of view is already a 'create view' statement so no need to
338 foreach ( $schema->get_views ) {
339 my $name = $_->name();
341 $output .= "--\n-- View: $name\n--" unless $no_comments;
342 my $text = $_->sql();
347 # Text of procedure already has the 'create procedure' stuff
348 # so there is no need to do anything fancy. However, we should
349 # think about doing fancy stuff with granting permissions and
351 foreach ( $schema->get_procedures ) {
352 my $name = $_->name();
354 $output .= "--\n-- Procedure: $name\n--" unless $no_comments;
355 my $text = $_->sql();
360 # Warn out how we messed with the names.
363 warn "Truncated " . keys( %truncated ) . " names:\n";
364 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
367 warn "Encounted " . keys( %unreserve ) .
368 " unsafe names in schema (reserved or invalid):\n";
369 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
376 # -------------------------------------------------------------------
378 my $basename = shift || '';
379 my $type = shift || '';
380 my $scope = shift || '';
381 my $critical = shift || '';
382 my $basename_orig = $basename;
384 ? $max_id_length - (length($type) + 1)
386 $basename = substr( $basename, 0, $max_name )
387 if length( $basename ) > $max_name;
388 my $name = $type ? "${type}_$basename" : $basename;
390 if ( $basename ne $basename_orig and $critical ) {
391 my $show_type = $type ? "+'$type'" : "";
392 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
393 "character limit to make '$name'\n" if $WARN;
394 $truncated{ $basename_orig } = $name;
397 $scope ||= \%global_names;
398 if ( my $prev = $scope->{ $name } ) {
399 my $name_orig = $name;
400 $name .= sprintf( "%02d", ++$prev );
401 substr($name, $max_id_length - 3) = "00"
402 if length( $name ) > $max_id_length;
404 warn "The name '$name_orig' has been changed to ",
405 "'$name' to make it unique.\n" if $WARN;
407 $scope->{ $name_orig }++;
409 $name = substr( $name, 0, $max_id_length )
410 if ((length( $name ) > $max_id_length) && $critical);
415 # -------------------------------------------------------------------
417 my $name = shift || '';
418 my $schema_obj_name = shift || '';
419 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
421 # also trap fields that don't begin with a letter
422 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
424 if ( $schema_obj_name ) {
425 ++$unreserve{"$schema_obj_name.$name"};
428 ++$unreserve{"$name (table name)"};
431 my $unreserve = sprintf '%s_', $name;
432 return $unreserve.$suffix;
437 # -------------------------------------------------------------------
447 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
448 Sybase producer, I just tweaked it for SQLServer. Thanks.