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 havn't been tested at all.
  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 %used_identifiers = ();
 111 my %global_names;
 112 my %unreserve;
 113 my %truncated;
 114
 115 =pod
 116
 117 =head1 SQLServer Create Table Syntax
 118
 119 TODO
 120
 121 =cut
 122
 123 # -------------------------------------------------------------------
 124 sub produce {
 125     my $translator     = shift;
 126     $DEBUG             = $translator->debug;
 127     $WARN              = $translator->show_warnings;
 128     my $no_comments    = $translator->no_comments;
 129     my $add_drop_table = $translator->add_drop_table;
 130     my $schema         = $translator->schema;
 131
 132     my $output;
 133     $output .= header_comment."\n" unless ($no_comments);
 134
 135     # Generate the DROP statements. We do this in one block here as if we
 136     # have fkeys we need to drop in the correct order otherwise they will fail
 137     # due to the dependancies the fkeys setup. (There is no way to turn off
 138     # fkey checking while we sort the schema like MySQL's set
 139     # foreign_key_checks=0)
 140     # We assume the tables are in the correct order to set them up as you need
 141     # to have created a table to fkey to it. So the reverse order should drop
 142     # them properly, fingers crossed...
 143     if ($add_drop_table) {
 144         $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
 145         foreach my $table (
 146             sort { $b->order <=> $a->order } $schema->get_tables
 147         ) {
 148             my $name = unreserve($table->name);
 149             $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
 150         }
 151     }
 152
 153     # Generate the CREATE sql
 154     for my $table ( $schema->get_tables ) {
 155         my $table_name    = $table->name or next;
 156         $table_name       = mk_name( $table_name, '', undef, 1 );
 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    = mk_name(
 172                 $field->name, '', \%field_name_scope, undef,1
 173             );
 174             my $field_name_ur = unreserve( $field_name, $table_name );
 175             my $field_def     = qq["$field_name_ur"];
 176             $field_def        =~ s/\"//g;
 177             if ( $field_def =~ /identity/ ){
 178                 $field_def =~ s/identity/pidentity/;
 179             }
 180
 181             #
 182             # Datatype
 183             #
 184             my $data_type      = lc $field->data_type;
 185             my $orig_data_type = $data_type;
 186             my %extra          = $field->extra;
 187             my $list           = $extra{'list'} || [];
 188             # \todo deal with embedded quotes
 189             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 190
 191             if ( $data_type eq 'enum' ) {
 192                 my $check_name = mk_name(
 193                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 194                 );
 195                 push @constraint_defs,
 196                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 197                 $data_type .= 'character varying';
 198             }
 199             elsif ( $data_type eq 'set' ) {
 200                 $data_type .= 'character varying';
 201             }
 202             else {
 203                 if ( defined $translate{ $data_type } ) {
 204                     $data_type = $translate{ $data_type };
 205                 }
 206                 else {
 207                     warn "Unknown datatype: $data_type ",
 208                         "($table_name.$field_name)\n" if $WARN;
 209                 }
 210             }
 211
 212             my $size = $field->size;
 213             if ( grep $_ eq $data_type, @no_size) {
 214             # SQLServer doesn't seem to like sizes on some datatypes
 215                 $size = undef;
 216             }
 217             elsif ( !$size ) {
 218                 if ( $data_type =~ /numeric/ ) {
 219                     $size = '9,0';
 220                 }
 221                 elsif ( $orig_data_type eq 'text' ) {
 222                     #interpret text fields as long varchars
 223                     $size = '255';
 224                 }
 225                 elsif (
 226                     $data_type eq 'varchar' &&
 227                     $orig_data_type eq 'boolean'
 228                 ) {
 229                     $size = '6';
 230                 }
 231                 elsif ( $data_type eq 'varchar' ) {
 232                     $size = '255';
 233                 }
 234             }
 235
 236             $field_def .= " $data_type";
 237             $field_def .= "($size)" if $size;
 238
 239             $field_def .= ' IDENTITY' if $field->is_auto_increment;
 240
 241             #
 242             # Not null constraint
 243             #
 244             unless ( $field->is_nullable ) {
 245                 $field_def .= ' NOT NULL';
 246             }
 247             else {
 248                 $field_def .= ' NULL' if $data_type ne 'bit';
 249             }
 250
 251             #
 252             # Default value
 253             #
 254             my $default = $field->default_value;
 255             if ( defined $default ) {
 256                 SQL::Translator::Producer->_apply_default_value(
 257                   \$field_def,
 258                   $default,
 259                   [
 260                     'NULL'       => \'NULL',
 261                   ],
 262                 );
 263             }
 264
 265             push @field_defs, $field_def;
 266         }
 267
 268         #
 269         # Constraint Declarations
 270         #
 271         my @constraint_decs = ();
 272         my $c_name_default;
 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 ) }
 279                 $constraint->fields;
 280             my @rfields = map { unreserve( $_, $table_name ) }
 281                 $constraint->reference_fields;
 282             next unless @fields;
 283
 284                         my $c_def;
 285             if ( $type eq PRIMARY_KEY ) {
 286                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 287                 $c_def =
 288                     "CONSTRAINT $name PRIMARY KEY ".
 289                     '(' . join( ', ', @fields ) . ')';
 290             }
 291             elsif ( $type eq FOREIGN_KEY ) {
 292                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 293                 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
 294                 $c_def =
 295                     "CONSTRAINT $name FOREIGN KEY".
 296                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 297                     $constraint->reference_table.
 298                     ' (' . join( ', ', @rfields ) . ')';
 299                  my $on_delete = $constraint->on_delete;
 300                  if ( defined $on_delete && $on_delete ne "NO ACTION") {
 301                         $c_def .= " ON DELETE $on_delete";
 302                  }
 303                  my $on_update = $constraint->on_update;
 304                  if ( defined $on_update && $on_update ne "NO ACTION") {
 305                         $c_def .= " ON UPDATE $on_update";
 306                  }
 307             }
 308             elsif ( $type eq UNIQUE ) {
 309                 $name ||= mk_name(
 310                     $table_name,
 311                     $name || ++$c_name_default,undef, 1
 312                 );
 313                 $c_def =
 314                     "CONSTRAINT $name UNIQUE " .
 315                     '(' . join( ', ', @fields ) . ')';
 316             }
 317             push @constraint_defs, $c_def;
 318         }
 319
 320         #
 321         # Indices
 322         #
 323         for my $index ( $table->get_indices ) {
 324             my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
 325             push @index_defs,
 326                 "CREATE INDEX $idx_name ON $table_name (".
 327                 join( ', ', $index->fields ) . ");";
 328         }
 329
 330         my $create_statement = "";
 331         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 332             join( ",\n",
 333                 map { "  $_" } @field_defs, @constraint_defs
 334             ).
 335             "\n);"
 336         ;
 337
 338         $output .= join( "\n\n",
 339             @comments,
 340             $create_statement,
 341             @index_defs,
 342             ''
 343         );
 344     }
 345
 346     # Text of view is already a 'create view' statement so no need to
 347     # be fancy
 348     foreach ( $schema->get_views ) {
 349         my $name = $_->name();
 350         $output .= "\n\n";
 351         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 352         my $text = $_->sql();
 353                 $text =~ s/\r//g;
 354         $output .= "$text\nGO\n";
 355     }
 356
 357     # Text of procedure already has the 'create procedure' stuff
 358     # so there is no need to do anything fancy. However, we should
 359     # think about doing fancy stuff with granting permissions and
 360     # so on.
 361     foreach ( $schema->get_procedures ) {
 362         my $name = $_->name();
 363         $output .= "\n\n";
 364         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 365         my $text = $_->sql();
 366                 $text =~ s/\r//g;
 367         $output .= "$text\nGO\n";
 368     }
 369
 370     # Warn out how we messed with the names.
 371     if ( $WARN ) {
 372         if ( %truncated ) {
 373             warn "Truncated " . keys( %truncated ) . " names:\n";
 374             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 375         }
 376         if ( %unreserve ) {
 377             warn "Encounted " . keys( %unreserve ) .
 378                 " unsafe names in schema (reserved or invalid):\n";
 379             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 380         }
 381     }
 382
 383     return $output;
 384 }
 385
 386 # -------------------------------------------------------------------
 387 sub mk_name {
 388     my $basename      = shift || '';
 389     my $type          = shift || '';
 390     my $scope         = shift || '';
 391     my $critical      = shift || '';
 392     my $basename_orig = $basename;
 393     my $max_name      = $type
 394                         ? $max_id_length - (length($type) + 1)
 395                         : $max_id_length;
 396     $basename         = substr( $basename, 0, $max_name )
 397                         if length( $basename ) > $max_name;
 398     my $name          = $type ? "${type}_$basename" : $basename;
 399
 400     if ( $basename ne $basename_orig and $critical ) {
 401         my $show_type = $type ? "+'$type'" : "";
 402         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 403             "character limit to make '$name'\n" if $WARN;
 404         $truncated{ $basename_orig } = $name;
 405     }
 406
 407     $scope ||= \%global_names;
 408     if ( my $prev = $scope->{ $name } ) {
 409         my $name_orig = $name;
 410         $name        .= sprintf( "%02d", ++$prev );
 411         substr($name, $max_id_length - 3) = "00"
 412             if length( $name ) > $max_id_length;
 413
 414         warn "The name '$name_orig' has been changed to ",
 415              "'$name' to make it unique.\n" if $WARN;
 416
 417         $scope->{ $name_orig }++;
 418     }
 419     $name = substr( $name, 0, $max_id_length )
 420                         if ((length( $name ) > $max_id_length) && $critical);
 421     $scope->{ $name }++;
 422     return $name;
 423 }
 424
 425 # -------------------------------------------------------------------
 426 sub unreserve {
 427     my $name            = shift || '';
 428     my $schema_obj_name = shift || '';
 429     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 430
 431     # also trap fields that don't begin with a letter
 432     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 433
 434     if ( $schema_obj_name ) {
 435         ++$unreserve{"$schema_obj_name.$name"};
 436     }
 437     else {
 438         ++$unreserve{"$name (table name)"};
 439     }
 440
 441     my $unreserve = sprintf '%s_', $name;
 442     return $unreserve.$suffix;
 443 }
 444
 445 1;
 446
 447 # -------------------------------------------------------------------
 448
 449 =pod
 450
 451 =head1 SEE ALSO
 452
 453 SQL::Translator.
 454
 455 =head1 AUTHORS
 456
 457 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 458 Sybase producer, I just tweaked it for SQLServer. Thanks.
 459
 460 =cut