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
156 my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
158 for my $table ( $schema->get_tables ) {
159 my $table_name = $table->name or next;
160 my $table_name_ur = unreserve($table_name) || '';
162 my ( @comments, @field_defs, @index_defs, @constraint_defs );
164 push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
167 push @comments, map { "-- $_" } $table->comments;
172 my %field_name_scope;
173 for my $field ( $table->get_fields ) {
174 my $field_name = $field->name;
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( $field_name . '_chk' );
194 push @constraint_defs,
195 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
196 $data_type .= 'character varying';
198 elsif ( $data_type eq 'set' ) {
199 $data_type .= 'character varying';
201 elsif ( grep { $data_type eq $_ } qw/bytea blob clob/ ) {
202 $data_type = 'varbinary';
205 if ( defined $translate{ $data_type } ) {
206 $data_type = $translate{ $data_type };
209 warn "Unknown datatype: $data_type ",
210 "($table_name.$field_name)\n" if $WARN;
214 my $size = $field->size;
215 if ( grep $_ eq $data_type, @no_size) {
216 # SQLServer doesn't seem to like sizes on some datatypes
220 if ( $data_type =~ /numeric/ ) {
223 elsif ( $orig_data_type eq 'text' ) {
224 #interpret text fields as long varchars
228 $data_type eq 'varchar' &&
229 $orig_data_type eq 'boolean'
233 elsif ( $data_type eq 'varchar' ) {
238 $field_def .= " $data_type";
239 $field_def .= "($size)" if $size;
241 $field_def .= ' IDENTITY' if $field->is_auto_increment;
244 # Not null constraint
246 unless ( $field->is_nullable ) {
247 $field_def .= ' NOT NULL';
250 $field_def .= ' NULL' if $data_type ne 'bit';
256 my $default = $field->default_value;
257 if ( defined $default ) {
258 SQL::Translator::Producer->_apply_default_value(
267 push @field_defs, $field_def;
271 # Constraint Declarations
273 my @constraint_decs = ();
274 for my $constraint ( $table->get_constraints ) {
275 my $name = $constraint->name || '';
276 # Make sure we get a unique 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 FOREIGN_KEY ) {
286 $name ||= mk_name( $table_name . '_fk' );
287 my $on_delete = uc ($constraint->on_delete || '');
288 my $on_update = uc ($constraint->on_update || '');
290 # The default implicit constraint action in MSSQL is RESTRICT
291 # but you can not specify it explicitly. Go figure :)
292 for ($on_delete, $on_update) {
293 undef $_ if $_ eq 'RESTRICT'
297 "ALTER TABLE $table_name ADD CONSTRAINT $name FOREIGN KEY".
298 ' (' . join( ', ', @fields ) . ') REFERENCES '.
299 $constraint->reference_table.
300 ' (' . join( ', ', @rfields ) . ')'
303 if ( $on_delete && $on_delete ne "NO ACTION") {
304 $c_def .= " ON DELETE $on_delete";
306 if ( $on_update && $on_update ne "NO ACTION") {
307 $c_def .= " ON UPDATE $on_update";
312 push @foreign_constraints, $c_def;
317 if ( $type eq PRIMARY_KEY ) {
318 $name ||= mk_name( $table_name . '_pk' );
320 "CONSTRAINT $name PRIMARY KEY ".
321 '(' . join( ', ', @fields ) . ')';
323 elsif ( $type eq UNIQUE ) {
324 $name ||= mk_name( $table_name . '_uc' );
326 "CONSTRAINT $name UNIQUE " .
327 '(' . join( ', ', @fields ) . ')';
329 push @constraint_defs, $c_def;
335 for my $index ( $table->get_indices ) {
336 my $idx_name = $index->name || mk_name($table_name . '_idx');
338 "CREATE INDEX $idx_name ON $table_name (".
339 join( ', ', $index->fields ) . ");";
342 my $create_statement = "";
343 $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
345 map { " $_" } @field_defs, @constraint_defs
350 $output .= join( "\n\n",
358 $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
360 # create view/procedure are NOT prepended to the input $sql, needs
361 # to be filled in with the proper syntax
365 # Text of view is already a 'create view' statement so no need to
367 foreach ( $schema->get_views ) {
368 my $name = $_->name();
370 $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
371 my $text = $_->sql();
373 $output .= "$text\nGO\n";
376 # Text of procedure already has the 'create procedure' stuff
377 # so there is no need to do anything fancy. However, we should
378 # think about doing fancy stuff with granting permissions and
380 foreach ( $schema->get_procedures ) {
381 my $name = $_->name();
383 $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
384 my $text = $_->sql();
386 $output .= "$text\nGO\n";
393 # -------------------------------------------------------------------
395 my ($name, $scope, $critical) = @_;
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.