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
  64 my %translate  = (
  65     date      => 'datetime',
  66     'time'    => 'datetime',
  67     # Sybase types
  68     #integer   => 'numeric',
  69     #int       => 'numeric',
  70     #number    => 'numeric',
  71     #money     => 'money',
  72     #varchar   => 'varchar',
  73     #varchar2  => 'varchar',
  74     #timestamp => 'datetime',
  75     #text      => 'varchar',
  76     #real      => 'double precision',
  77     #comment   => 'text',
  78     #bit       => 'bit',
  79     #tinyint   => 'smallint',
  80     #float     => 'double precision',
  81     #serial    => 'numeric',
  82     #boolean   => 'varchar',
  83     #char      => 'char',
  84     #long      => 'varchar',
  85 );
  86
  87 # TODO - This is still the Sybase list!
  88 my %reserved = map { $_, 1 } qw[
  89     ALL ANALYSE ANALYZE AND ANY AS ASC
  90     BETWEEN BINARY BOTH
  91     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  92     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  93     DEFAULT DEFERRABLE DESC DISTINCT DO
  94     ELSE END EXCEPT
  95     FALSE FOR FOREIGN FREEZE FROM FULL
  96     GROUP HAVING
  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
 104 ];
 105
 106 # If these datatypes have size appended the sql fails.
 107 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
 108
 109 my $max_id_length    = 128;
 110 my %global_names;
 111 my %unreserve;
 112
 113 =pod
 114
 115 =head1 SQLServer Create Table Syntax
 116
 117 TODO
 118
 119 =cut
 120
 121 # -------------------------------------------------------------------
 122 sub produce {
 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;
 129
 130     %global_names = (); #reset
 131     %unreserve = ();
 132
 133     my $output;
 134     $output .= header_comment."\n" unless ($no_comments);
 135
 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;
 146         foreach my $table (
 147             sort { $b->order <=> $a->order } $schema->get_tables
 148         ) {
 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}
 151         }
 152     }
 153
 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) || '';
 158
 159         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 160
 161         push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
 162         unless $no_comments;
 163
 164         push @comments, map { "-- $_" } $table->comments;
 165
 166         #
 167         # Fields
 168         #
 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/;
 177             }
 178
 179             #
 180             # Datatype
 181             #
 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 );
 188
 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';
 194             }
 195             elsif ( $data_type eq 'set' ) {
 196                 $data_type .= 'character varying';
 197             }
 198             else {
 199                 if ( defined $translate{ $data_type } ) {
 200                     $data_type = $translate{ $data_type };
 201                 }
 202                 else {
 203                     warn "Unknown datatype: $data_type ",
 204                         "($table_name.$field_name)\n" if $WARN;
 205                 }
 206             }
 207
 208             my $size = $field->size;
 209             if ( grep $_ eq $data_type, @no_size) {
 210             # SQLServer doesn't seem to like sizes on some datatypes
 211                 $size = undef;
 212             }
 213             elsif ( !$size ) {
 214                 if ( $data_type =~ /numeric/ ) {
 215                     $size = '9,0';
 216                 }
 217                 elsif ( $orig_data_type eq 'text' ) {
 218                     #interpret text fields as long varchars
 219                     $size = '255';
 220                 }
 221                 elsif (
 222                     $data_type eq 'varchar' &&
 223                     $orig_data_type eq 'boolean'
 224                 ) {
 225                     $size = '6';
 226                 }
 227                 elsif ( $data_type eq 'varchar' ) {
 228                     $size = '255';
 229                 }
 230             }
 231
 232             $field_def .= " $data_type";
 233             $field_def .= "($size)" if $size;
 234
 235             $field_def .= ' IDENTITY' if $field->is_auto_increment;
 236
 237             #
 238             # Not null constraint
 239             #
 240             unless ( $field->is_nullable ) {
 241                 $field_def .= ' NOT NULL';
 242             }
 243             else {
 244                 $field_def .= ' NULL' if $data_type ne 'bit';
 245             }
 246
 247             #
 248             # Default value
 249             #
 250             my $default = $field->default_value;
 251             if ( defined $default ) {
 252                 SQL::Translator::Producer->_apply_default_value(
 253                   \$field_def,
 254                   $default,
 255                   [
 256                     'NULL'       => \'NULL',
 257                   ],
 258                 );
 259             }
 260
 261             push @field_defs, $field_def;
 262         }
 263
 264         #
 265         # Constraint Declarations
 266         #
 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 ) }
 273                 $constraint->fields;
 274             my @rfields = map { unreserve( $_, $table_name ) }
 275                 $constraint->reference_fields;
 276             next unless @fields;
 277
 278                         my $c_def;
 279             if ( $type eq PRIMARY_KEY ) {
 280                 $name ||= mk_name( $table_name . '_pk' );
 281                 $c_def =
 282                     "CONSTRAINT $name PRIMARY KEY ".
 283                     '(' . join( ', ', @fields ) . ')';
 284             }
 285             elsif ( $type eq FOREIGN_KEY ) {
 286                 $name ||= mk_name( $table_name . '_fk' );
 287                 $c_def =
 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";
 295                  }
 296                  my $on_update = $constraint->on_update;
 297                  if ( $on_update && $on_update ne "NO ACTION") {
 298                         $c_def .= " ON UPDATE $on_update";
 299                  }
 300             }
 301             elsif ( $type eq UNIQUE ) {
 302                 $name ||= mk_name( $table_name . '_uc' );
 303                 $c_def =
 304                     "CONSTRAINT $name UNIQUE " .
 305                     '(' . join( ', ', @fields ) . ')';
 306             }
 307             push @constraint_defs, $c_def;
 308         }
 309
 310         #
 311         # Indices
 312         #
 313         for my $index ( $table->get_indices ) {
 314             my $idx_name = $index->name || mk_name($table_name . '_idx');
 315             push @index_defs,
 316                 "CREATE INDEX $idx_name ON $table_name (".
 317                 join( ', ', $index->fields ) . ");";
 318         }
 319
 320         my $create_statement = "";
 321         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 322             join( ",\n",
 323                 map { "  $_" } @field_defs, @constraint_defs
 324             ).
 325             "\n);"
 326         ;
 327
 328         $output .= join( "\n\n",
 329             @comments,
 330             $create_statement,
 331             @index_defs,
 332         );
 333     }
 334
 335 # create view/procedure are NOT prepended to the input $sql, needs
 336 # to be filled in with the proper syntax
 337
 338 =pod
 339
 340     # Text of view is already a 'create view' statement so no need to
 341     # be fancy
 342     foreach ( $schema->get_views ) {
 343         my $name = $_->name();
 344         $output .= "\n\n";
 345         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 346         my $text = $_->sql();
 347         $text =~ s/\r//g;
 348         $output .= "$text\nGO\n";
 349     }
 350
 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
 354     # so on.
 355     foreach ( $schema->get_procedures ) {
 356         my $name = $_->name();
 357         $output .= "\n\n";
 358         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 359         my $text = $_->sql();
 360                 $text =~ s/\r//g;
 361         $output .= "$text\nGO\n";
 362     }
 363 =cut
 364
 365     return $output;
 366 }
 367
 368 # -------------------------------------------------------------------
 369 sub mk_name {
 370     my ($name, $scope, $critical) = @_;
 371
 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;
 378
 379         warn "The name '$name_orig' has been changed to ",
 380              "'$name' to make it unique.\n" if $WARN;
 381
 382         $scope->{ $name_orig }++;
 383     }
 384     $name = substr( $name, 0, $max_id_length )
 385                         if ((length( $name ) > $max_id_length) && $critical);
 386     $scope->{ $name }++;
 387     return $name;
 388 }
 389
 390 # -------------------------------------------------------------------
 391 sub unreserve {
 392     my $name            = shift || '';
 393     my $schema_obj_name = shift || '';
 394     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 395
 396     # also trap fields that don't begin with a letter
 397     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 398
 399     if ( $schema_obj_name ) {
 400         ++$unreserve{"$schema_obj_name.$name"};
 401     }
 402     else {
 403         ++$unreserve{"$name (table name)"};
 404     }
 405
 406     my $unreserve = sprintf '%s_', $name;
 407     return $unreserve.$suffix;
 408 }
 409
 410 1;
 411
 412 # -------------------------------------------------------------------
 413
 414 =pod
 415
 416 =head1 SEE ALSO
 417
 418 SQL::Translator.
 419
 420 =head1 AUTHORS
 421
 422 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 423 Sybase producer, I just tweaked it for SQLServer. Thanks.
 424
 425 =cut