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