lib/SQL/Translator/Producer/SQLServer.pm

   1 package SQL::Translator::Producer::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # Copyright (C) 2002-2009 SQLFairy Authors
   5 #
   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.
   9 #
  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.
  14 #
  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
  18 # 02111-1307  USA
  19 # -------------------------------------------------------------------
  20
  21 =head1 NAME
  22
  23 SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator
  24
  25 =head1 SYNOPSIS
  26
  27   use SQL::Translator;
  28
  29   my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
  30   $t->translate;
  31
  32 =head1 DESCRIPTION
  33
  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 ;-)
  36
  37 =head1 Extra Attributes
  38
  39 =over 4
  40
  41 =item field.list
  42
  43 List of values for an enum field.
  44
  45 =back
  46
  47 =head1 TODO
  48
  49  * !! Write some tests !!
  50  * Reserved words list needs updating to SQLServer.
  51  * Triggers, Procedures and Views DO NOT WORK
  52
  53 =cut
  54
  55 use strict;
  56 use vars qw[ $DEBUG $WARN $VERSION ];
  57 $VERSION = '1.59';
  58 $DEBUG = 1 unless defined $DEBUG;
  59
  60 use Data::Dumper;
  61 use SQL::Translator::Schema::Constants;
  62 use SQL::Translator::Utils qw(debug header_comment);
  63 use SQL::Translator::ProducerUtils;
  64
  65 my $util = SQL::Translator::ProducerUtils->new( quote_chars => ['[', ']'] );
  66
  67 my %translate  = (
  68     date       => 'datetime',
  69     'time'     => 'datetime',
  70     enum       => 'varchar',
  71     bytea      => 'varbinary',
  72     blob       => 'varbinary',
  73     clob       => 'varbinary',
  74     tinyblob   => 'varbinary',
  75     mediumblob => 'varbinary',
  76     longblob   => 'varbinary'
  77 );
  78
  79 # If these datatypes have size appended the sql fails.
  80 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
  81
  82 my $max_id_length    = 128;
  83 my %global_names;
  84
  85 =pod
  86
  87 =head1 SQLServer Create Table Syntax
  88
  89 TODO
  90
  91 =cut
  92
  93 # -------------------------------------------------------------------
  94 sub produce {
  95     my $translator     = shift;
  96     $DEBUG             = $translator->debug;
  97     $WARN              = $translator->show_warnings;
  98     my $no_comments    = $translator->no_comments;
  99     my $add_drop_table = $translator->add_drop_table;
 100     my $schema         = $translator->schema;
 101     my $options= {
 102         add_drop_table    => $add_drop_table,
 103         show_warnings     => $WARN,
 104         no_comments       => $no_comments,
 105     };
 106
 107     %global_names = (); #reset
 108
 109     my $output;
 110     $output .= header_comment."\n" unless ($no_comments);
 111
 112     # Generate the DROP statements.
 113     if ($add_drop_table) {
 114         my @tables = sort { $b->order <=> $a->order } $schema->get_tables;
 115         $output .= "--\n-- Turn off constraints\n--\n\n" unless $no_comments;
 116         foreach my $table (@tables) {
 117             my $name = $table->name;
 118             my $q_name = $util->quote( $name );
 119             $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') ALTER TABLE $q_name NOCHECK CONSTRAINT all;\n"
 120         }
 121         $output .= "\n";
 122         $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
 123         foreach my $table (@tables) {
 124             my $name = $table->name;
 125             my $q_name = $util->quote( $name );
 126             $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $q_name;\n"
 127         }
 128     }
 129
 130     # Generate the CREATE sql
 131
 132     my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
 133
 134     for my $table ( $schema->get_tables ) {
 135         my $table_name   = $table->name or next;
 136         my $table_name_q = $util->quote( $table_name );
 137
 138         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 139
 140         push @comments, "\n\n--\n-- Table: $table_name_q\n--"
 141         unless $no_comments;
 142
 143         push @comments, map { "-- $_" } $table->comments;
 144
 145         #
 146         # Fields
 147         #
 148         for my $field ( $table->get_fields ) {
 149             my $field_clause= build_field_clause($field, $options);
 150             if (lc($field->data_type) eq 'enum') {
 151                 push @constraint_defs, build_enum_constraint($field, $options);
 152             }
 153             push @field_defs, $field_clause;
 154         }
 155
 156         #
 157         # Constraint Declarations
 158         #
 159         my @constraint_defs = ();
 160         for my $constraint ( $table->get_constraints ) {
 161             next unless $constraint->fields;
 162             my ($stmt, $createClause)= build_constraint_stmt($constraint, $options);
 163             # use a clause, if the constraint can be written that way
 164             if ($createClause) {
 165                 push @constraint_defs, $createClause;
 166             }
 167             # created a foreign key statement, which we save til the end
 168             elsif ( $constraint->type eq FOREIGN_KEY ) {
 169                 push @foreign_constraints, $stmt;
 170             }
 171             # created an index statement, instead of a clause, which we append to "create table"
 172             else { #if ( $constraint->type eq UNIQUE ) {
 173                 push @index_defs, $stmt;
 174             }
 175         }
 176
 177         #
 178         # Indices
 179         #
 180         for my $index ( $table->get_indices ) {
 181             my $idx_name = $index->name || unique_name($table_name . '_idx');
 182             my $idx_name_q = $util->quote($idx_name);
 183             push @index_defs,
 184                 "CREATE INDEX $idx_name_q ON $table_name_q (".
 185                 join( ', ', map { $util->quote($_) } $index->fields ) . ");";
 186         }
 187
 188         my $create_statement = "";
 189         $create_statement .= "CREATE TABLE $table_name_q (\n".
 190             join( ",\n",
 191                 map { "  $_" } @field_defs, @constraint_defs
 192             ).
 193             "\n);"
 194         ;
 195
 196         $output .= join( "\n\n",
 197             @comments,
 198             $create_statement,
 199             @index_defs,
 200         );
 201     }
 202
 203 # Add FK constraints
 204     $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
 205
 206 # create view/procedure are NOT prepended to the input $sql, needs
 207 # to be filled in with the proper syntax
 208
 209 =pod
 210
 211     # Text of view is already a 'create view' statement so no need to
 212     # be fancy
 213     foreach ( $schema->get_views ) {
 214         my $name = $_->name();
 215         $output .= "\n\n";
 216         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 217         my $text = $_->sql();
 218         $text =~ s/\r//g;
 219         $output .= "$text\nGO\n";
 220     }
 221
 222     # Text of procedure already has the 'create procedure' stuff
 223     # so there is no need to do anything fancy. However, we should
 224     # think about doing fancy stuff with granting permissions and
 225     # so on.
 226     foreach ( $schema->get_procedures ) {
 227         my $name = $_->name();
 228         $output .= "\n\n";
 229         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 230         my $text = $_->sql();
 231       $text =~ s/\r//g;
 232         $output .= "$text\nGO\n";
 233     }
 234 =cut
 235
 236     return $output;
 237 }
 238
 239 sub alter_field {
 240     my ($from_field, $to_field, $options) = @_;
 241
 242     my $field_clause= build_field_clause($to_field, $options);
 243     my $table_name_q= $util->quote($to_field->table->name);
 244
 245     my @sql;
 246     if (lc($from_field->data_type) eq 'enum') {
 247         push @sql, build_drop_enum_constraint($from_field, $options).';';
 248     }
 249
 250     push @sql, "ALTER TABLE $table_name_q ALTER COLUMN $field_clause;";
 251
 252     if ($from_field->name ne $to_field->name) {
 253         push @sql, rename_field(@_);
 254     }
 255
 256     if (lc($to_field->data_type) eq 'enum') {
 257         push @sql, build_add_enum_constraint($to_field, $options).';';
 258     }
 259
 260     return join("\n", @sql);
 261 }
 262
 263 sub build_rename_field {
 264     my ($from_field, $to_field, $options) = @_;
 265
 266     return sprintf "EXEC sp_rename \@objname = '%s', \@newname = '%s', \@objtype = 'COLUMN';",
 267            $from_field->name,
 268            $to_field->name;
 269 }
 270
 271 sub add_field {
 272     my ($new_field, $options) = @_;
 273
 274     my $field_clause= build_field_clause(@_);
 275     my $table_name_q= $util->quote($new_field->table->name);
 276
 277     my @sql= "ALTER TABLE $table_name_q ADD COLUMN $field_clause;";
 278     if (lc($new_field->data_type) eq 'enum') {
 279         push @sql, build_add_enum_constraint($new_field, $options).';';
 280     }
 281
 282     return join("\n", @sql);
 283 }
 284
 285 sub drop_field {
 286     my ($old_field, $options) = @_;
 287
 288     my $table_name_q= $util->quote($old_field->table->name);
 289     my $field_name_q= $util->quote($old_field->name);
 290
 291     my @sql;
 292     if (lc($old_field->data_type) eq 'enum') {
 293         push @sql, build_drop_enum_constraint($old_field, $options).';';
 294     }
 295
 296     push @sql, "ALTER TABLE $table_name_q DROP COLUMN $field_name_q;";
 297
 298     return join("\n", @sql);
 299 }
 300
 301 sub alter_create_constraint {
 302     my ($constraint, $options) = @_;
 303     my ($stmt, $clause)= build_constraint_stmt(@_);
 304     return $stmt.';';
 305 }
 306
 307 sub alter_drop_constraint {
 308     my ($constraint, $options) = @_;
 309     my $table_name_q= $util->quote($constraint->table->name);
 310     my $ct_name_q= $util->quote($constraint->name);
 311     return "ALTER TABLE $table_name_q DROP CONSTRAINT $ct_name_q;";
 312 }
 313
 314 sub alter_create_index {
 315     my ($index, $options) = @_;
 316     my ($stmt, $clause)= build_index_stmt(@_);
 317     return $stmt.';';
 318 }
 319
 320 sub alter_drop_index {
 321     my ($index, $options) = @_;
 322     my $table_name_q= $util->quote($index->table->name);
 323     my $index_name_q= $util->quote($index->name);
 324     return "ALTER TABLE $table_name_q DROP $index_name_q";
 325 }
 326
 327 sub build_field_clause {
 328     my ($field, $options)= @_;
 329
 330     my $field_name   = $field->name;
 331     my $field_name_q = $util->quote($field_name);
 332     my $field_def    = $field_name_q;
 333
 334     #
 335     # Datatype
 336     #
 337     my $data_type      = lc $field->data_type;
 338     my $orig_data_type = $data_type;
 339     my %extra          = $field->extra;
 340     my $list           = $extra{'list'} || [];
 341     # \todo deal with embedded quotes
 342     my $commalist      = join( ', ', map { qq['$_'] } @$list );
 343     my $size           = $field->size;
 344
 345     if ( $data_type eq 'set' ) {
 346         # TODO: do we need more logic here?
 347         $data_type = 'varchar';
 348     }
 349     elsif ( defined $translate{ $data_type } ) {
 350         $data_type = $translate{ $data_type };
 351     }
 352     else {
 353         warn "Unknown datatype: $data_type ",
 354             "(".$field->table->name.".$field_name)\n" if $WARN;
 355     }
 356
 357     if ( grep $_ eq $data_type, @no_size) {
 358     # SQLServer doesn't seem to like sizes on some datatypes
 359         $size = undef;
 360     }
 361     elsif ( $data_type eq 'varbinary' ) {
 362         $size ||= 255 if $orig_data_type eq 'tinyblob';
 363         # SQL Server has a max specifyable size of 8000, but if you say 'max', you get 2^31.  Go figure.
 364         # Note that 'max' was introduced in SQL Server 2005.  Before that, you need a type of 'image',
 365         #   which is now deprecated.
 366         # TODO: add version support and return 'image' for old versions
 367         $size= 'max' if $size > 8000 || !$size;
 368     }
 369     elsif ( !$size ) {
 370         if ( $data_type =~ /numeric/ ) {
 371             $size = '9,0';
 372         }
 373         elsif ( $orig_data_type eq 'text' ) {
 374             #interpret text fields as long varchars
 375             $size = 255;
 376         }
 377         elsif (
 378             $data_type eq 'varchar' &&
 379             $orig_data_type eq 'boolean'
 380         ) {
 381             $size = '6';
 382         }
 383         elsif ( $data_type eq 'varchar' ) {
 384             $size = '255';
 385         }
 386     }
 387
 388     $field_def .= " $data_type";
 389     $field_def .= "($size)" if $size;
 390
 391     $field_def .= ' IDENTITY' if $field->is_auto_increment;
 392
 393     #
 394     # Not null constraint
 395     #
 396     unless ( $field->is_nullable ) {
 397         $field_def .= ' NOT NULL';
 398     }
 399     else {
 400         $field_def .= ' NULL' if $data_type ne 'bit';
 401     }
 402
 403     #
 404     # Default value
 405     #
 406     SQL::Translator::Producer->_apply_default_value(
 407       $field,
 408       \$field_def,
 409       [
 410         'NULL'       => \'NULL',
 411       ],
 412     );
 413
 414     return $field_def;
 415 }
 416
 417 sub build_enum_constraint {
 418     my ($field, $options)= @_;
 419     my %extra = $field->extra;
 420     my $list = $extra{'list'} || [];
 421     # \todo deal with embedded quotes
 422     my $commalist = join( ', ', map { qq['$_'] } @$list );
 423     my $field_name_q = $util->quote($field->name);
 424     my $check_name_q = $util->quote( unique_name( $field->table->name . '_' . $field->name . '_chk' ) );
 425     return "CONSTRAINT $check_name_q CHECK ($field_name_q IN ($commalist))";
 426 }
 427
 428 sub build_add_enum_constraint {
 429     my ($field, $options)= @_;
 430     my $table_name_q = $util->quote($field->table->name);
 431     return "ALTER TABLE $table_name_q ADD ".build_enum_constraint(@_);
 432 }
 433
 434 sub build_drop_enum_constraint {
 435     my ($field, $options)= @_;
 436     my $table_name_q = $util->quote($field->table->name);
 437     my $check_name_q = $util->quote( unique_name( $field->table->name . '_' . $field->name . '_chk' ) );
 438     return "ALTER TABLE $table_name_q DROP $check_name_q";
 439 }
 440
 441 # build_constraint_stmt($constraint, $options)
 442 # Returns ($stmt, $clause)
 443 #
 444 # Multiple return values are necessary because some things that you would
 445 #   like to be clauses in CREATE TABLE become separate statements.
 446 # $stmt will always be returned, but $clause might be undef
 447 #
 448 sub build_constraint_stmt {
 449     my ($constraint, $options)= @_;
 450     my $table_name_q = $util->quote($constraint->table->name);
 451     my $field_list   = join(', ', map { $util->quote($_) } $constraint->fields );
 452     my $type         = $constraint->type || NORMAL;
 453
 454     if ( $type eq FOREIGN_KEY ) {
 455         my $ct_name= $constraint->name || unique_name( $constraint->table->name . '_fk' );
 456         my $ct_name_q=    $util->quote($ct_name);
 457         my $ref_tbl_q=    $util->quote($constraint->reference_table);
 458         my $rfield_list=  join( ', ', map { $util->quote($_) } $constraint->reference_fields );
 459
 460         my $c_def =
 461             "ALTER TABLE $table_name_q ADD CONSTRAINT $ct_name_q ".
 462             "FOREIGN KEY ($field_list) REFERENCES $ref_tbl_q ($rfield_list)";
 463
 464         # The default implicit constraint action in MSSQL is RESTRICT
 465         # but you can not specify it explicitly. Go figure :)
 466         my $on_delete = uc ($constraint->on_delete || '');
 467         my $on_update = uc ($constraint->on_update || '');
 468         if ( $on_delete && $on_delete ne "NO ACTION" && $on_delete ne "RESTRICT") {
 469             $c_def .= " ON DELETE $on_delete";
 470         }
 471         if ( $on_update && $on_update ne "NO ACTION" && $on_delete ne "RESTRICT") {
 472             $c_def .= " ON UPDATE $on_update";
 473         }
 474
 475         return $c_def, undef;
 476     }
 477     elsif ( $type eq PRIMARY_KEY ) {
 478         my $ct_name=      $constraint->name || unique_name( $constraint->table->name . '_pk' );
 479         my $ct_name_q=    $util->quote($ct_name);
 480
 481         my $clause= "CONSTRAINT $ct_name_q PRIMARY KEY ($field_list)";
 482         my $stmt=   "ALTER TABLE $table_name_q ADD $clause";
 483         return $stmt, $clause;
 484     }
 485     elsif ( $type eq UNIQUE ) {
 486         my $ct_name=      $constraint->name || unique_name( $constraint->table->name . '_uc' );
 487         my $ct_name_q=    $util->quote($ct_name);
 488
 489         my @nullable = grep { $_->is_nullable } $constraint->fields;
 490         if (!@nullable) {
 491             my $clause= "CONSTRAINT $ct_name_q UNIQUE ($field_list)";
 492             my $stmt=   "ALTER TABLE $table_name_q ADD $clause";
 493             return $stmt, $clause;
 494         }
 495         else {
 496             my $where_clause= join(' AND ', map { $util->quote($_->name) . ' IS NOT NULL' } @nullable );
 497             my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $ct_name_q" .
 498                       " ON $table_name_q ($field_list)" .
 499                       " WHERE $where_clause";
 500             return $stmt, undef;
 501         }
 502     }
 503
 504     die "Unhandled constraint type $type";
 505 }
 506
 507 sub build_index_stmt {
 508     my ($index, $options)= @_;
 509     my $table_name_q = $util->quote($index->table->name);
 510     my $idx_name_q   = $util->quote($index->name);
 511     my $field_list   = join(', ', map { $util->quote($_) } $index->fields );
 512
 513     my $stmt= "CREATE UNIQUE NONCLUSTERED INDEX $idx_name_q" .
 514               " ON $table_name_q ($field_list)";
 515     return $stmt, undef;
 516 }
 517
 518 # -------------------------------------------------------------------
 519 sub unique_name {
 520     my ($name, $scope, $critical) = @_;
 521
 522     $scope ||= \%global_names;
 523     if ( my $prev = $scope->{ $name } ) {
 524         my $name_orig = $name;
 525         $name        .= sprintf( "%02d", ++$prev );
 526         substr($name, $max_id_length - 3) = "00"
 527             if length( $name ) > $max_id_length;
 528
 529         warn "The name '$name_orig' has been changed to '$name' to make it".
 530              "unique.\nThis can wreak havoc if you try generating upgrade or".
 531              "downgrade scripts.\n" if $WARN;
 532
 533         $scope->{ $name_orig }++;
 534     }
 535     $name = substr( $name, 0, $max_id_length )
 536                         if ((length( $name ) > $max_id_length) && $critical);
 537     $scope->{ $name }++;
 538     return $name;
 539 }
 540
 541 1;
 542
 543 # -------------------------------------------------------------------
 544
 545 =pod
 546
 547 =head1 SEE ALSO
 548
 549 SQL::Translator.
 550
 551 =head1 AUTHORS
 552
 553 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 554 Sybase producer, I just tweaked it for SQLServer. Thanks.
 555
 556 =cut