lib/SQL/Translator/Producer/SQLServer.pm

   1 package SQL::Translator::Producer::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLServer.pm 1440 2009-01-17 16:31:57Z jawnsy $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-2009 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =head1 NAME
  24
  25 SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator;
  30
  31   my $t = SQL::Translator->new( parser => '...', producer => 'SQLServer' );
  32   $t->translate;
  33
  34 =head1 DESCRIPTION
  35
  36 B<WARNING>B This is still fairly early code, basically a hacked version of the
  37 Sybase Producer (thanks Sam, Paul and Ken for doing the real work ;-)
  38
  39 =head1 Extra Attributes
  40
  41 =over 4
  42
  43 =item field.list
  44
  45 List of values for an enum field.
  46
  47 =back
  48
  49 =head1 TODO
  50
  51  * !! Write some tests !!
  52  * Reserved words list needs updating to SQLServer.
  53  * Triggers, Procedures and Views havn't been tested at all.
  54
  55 =cut
  56
  57 use strict;
  58 use vars qw[ $DEBUG $WARN ];
  59 $DEBUG = 1 unless defined $DEBUG;
  60
  61 use Data::Dumper;
  62 use SQL::Translator::Schema::Constants;
  63 use SQL::Translator::Utils qw(debug header_comment);
  64
  65 my %translate  = (
  66     date      => 'datetime',
  67     'time'    => 'datetime',
  68     # Sybase types
  69     #integer   => 'numeric',
  70     #int       => 'numeric',
  71     #number    => 'numeric',
  72     #money     => 'money',
  73     #varchar   => 'varchar',
  74     #varchar2  => 'varchar',
  75     #timestamp => 'datetime',
  76     #text      => 'varchar',
  77     #real      => 'double precision',
  78     #comment   => 'text',
  79     #bit       => 'bit',
  80     #tinyint   => 'smallint',
  81     #float     => 'double precision',
  82     #serial    => 'numeric',
  83     #boolean   => 'varchar',
  84     #char      => 'char',
  85     #long      => 'varchar',
  86 );
  87
  88 # TODO - This is still the Sybase list!
  89 my %reserved = map { $_, 1 } qw[
  90     ALL ANALYSE ANALYZE AND ANY AS ASC
  91     BETWEEN BINARY BOTH
  92     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  93     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  94     DEFAULT DEFERRABLE DESC DISTINCT DO
  95     ELSE END EXCEPT
  96     FALSE FOR FOREIGN FREEZE FROM FULL
  97     GROUP HAVING
  98     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
  99     JOIN LEADING LEFT LIKE LIMIT
 100     NATURAL NEW NOT NOTNULL NULL
 101     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 102     PRIMARY PUBLIC REFERENCES RIGHT
 103     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 104     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 105 ];
 106
 107 # If these datatypes have size appended the sql fails.
 108 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
 109
 110 my $max_id_length    = 128;
 111 my %used_identifiers = ();
 112 my %global_names;
 113 my %unreserve;
 114 my %truncated;
 115
 116 =pod
 117
 118 =head1 SQLServer Create Table Syntax
 119
 120 TODO
 121
 122 =cut
 123
 124 # -------------------------------------------------------------------
 125 sub produce {
 126     my $translator     = shift;
 127     $DEBUG             = $translator->debug;
 128     $WARN              = $translator->show_warnings;
 129     my $no_comments    = $translator->no_comments;
 130     my $add_drop_table = $translator->add_drop_table;
 131     my $schema         = $translator->schema;
 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         $table_name       = mk_name( $table_name, '', undef, 1 );
 158         my $table_name_ur = unreserve($table_name) || '';
 159
 160         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 161
 162         push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
 163         unless $no_comments;
 164
 165         push @comments, map { "-- $_" } $table->comments;
 166
 167         #
 168         # Fields
 169         #
 170         my %field_name_scope;
 171         for my $field ( $table->get_fields ) {
 172             my $field_name    = mk_name(
 173                 $field->name, '', \%field_name_scope, undef,1
 174             );
 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/;
 180             }
 181
 182             #
 183             # Datatype
 184             #
 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 );
 191
 192             if ( $data_type eq 'enum' ) {
 193                 my $check_name = mk_name(
 194                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 195                 );
 196                 push @constraint_defs,
 197                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 198                 $data_type .= 'character varying';
 199             }
 200             elsif ( $data_type eq 'set' ) {
 201                 $data_type .= 'character varying';
 202             }
 203             else {
 204                 if ( defined $translate{ $data_type } ) {
 205                     $data_type = $translate{ $data_type };
 206                 }
 207                 else {
 208                     warn "Unknown datatype: $data_type ",
 209                         "($table_name.$field_name)\n" if $WARN;
 210                 }
 211             }
 212
 213             my $size = $field->size;
 214             if ( grep $_ eq $data_type, @no_size) {
 215             # SQLServer doesn't seem to like sizes on some datatypes
 216                 $size = undef;
 217             }
 218             elsif ( !$size ) {
 219                 if ( $data_type =~ /numeric/ ) {
 220                     $size = '9,0';
 221                 }
 222                 elsif ( $orig_data_type eq 'text' ) {
 223                     #interpret text fields as long varchars
 224                     $size = '255';
 225                 }
 226                 elsif (
 227                     $data_type eq 'varchar' &&
 228                     $orig_data_type eq 'boolean'
 229                 ) {
 230                     $size = '6';
 231                 }
 232                 elsif ( $data_type eq 'varchar' ) {
 233                     $size = '255';
 234                 }
 235             }
 236
 237             $field_def .= " $data_type";
 238             $field_def .= "($size)" if $size;
 239
 240             $field_def .= ' IDENTITY' if $field->is_auto_increment;
 241
 242             #
 243             # Not null constraint
 244             #
 245             unless ( $field->is_nullable ) {
 246                 $field_def .= ' NOT NULL';
 247             }
 248             else {
 249                 $field_def .= ' NULL' if $data_type ne 'bit';
 250             }
 251
 252             #
 253             # Default value
 254             #
 255             my $default = $field->default_value;
 256             if ( defined $default ) {
 257                 SQL::Translator::Producer->_apply_default_value(
 258                   \$field_def,
 259                   $default,
 260                   [
 261                     'NULL'       => \'NULL',
 262                   ],
 263                 );
 264             }
 265
 266             push @field_defs, $field_def;
 267         }
 268
 269         #
 270         # Constraint Declarations
 271         #
 272         my @constraint_decs = ();
 273         my $c_name_default;
 274         for my $constraint ( $table->get_constraints ) {
 275             my $name    = $constraint->name || '';
 276             # Make sure we get a unique name
 277             $name       = mk_name( $name, undef, undef, 1 ) if $name;
 278             my $type    = $constraint->type || NORMAL;
 279             my @fields  = map { unreserve( $_, $table_name ) }
 280                 $constraint->fields;
 281             my @rfields = map { unreserve( $_, $table_name ) }
 282                 $constraint->reference_fields;
 283             next unless @fields;
 284
 285                         my $c_def;
 286             if ( $type eq PRIMARY_KEY ) {
 287                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 288                 $c_def =
 289                     "CONSTRAINT $name PRIMARY KEY ".
 290                     '(' . join( ', ', @fields ) . ')';
 291             }
 292             elsif ( $type eq FOREIGN_KEY ) {
 293                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 294                 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
 295                 $c_def =
 296                     "CONSTRAINT $name FOREIGN KEY".
 297                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 298                     $constraint->reference_table.
 299                     ' (' . join( ', ', @rfields ) . ')';
 300                  my $on_delete = $constraint->on_delete;
 301                  if ( defined $on_delete && $on_delete ne "NO ACTION") {
 302                         $c_def .= " ON DELETE $on_delete";
 303                  }
 304                  my $on_update = $constraint->on_update;
 305                  if ( defined $on_update && $on_update ne "NO ACTION") {
 306                         $c_def .= " ON UPDATE $on_update";
 307                  }
 308             }
 309             elsif ( $type eq UNIQUE ) {
 310                 $name ||= mk_name(
 311                     $table_name,
 312                     $name || ++$c_name_default,undef, 1
 313                 );
 314                 $c_def =
 315                     "CONSTRAINT $name UNIQUE " .
 316                     '(' . join( ', ', @fields ) . ')';
 317             }
 318             push @constraint_defs, $c_def;
 319         }
 320
 321         #
 322         # Indices
 323         #
 324         for my $index ( $table->get_indices ) {
 325             my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
 326             push @index_defs,
 327                 "CREATE INDEX $idx_name ON $table_name (".
 328                 join( ', ', $index->fields ) . ");";
 329         }
 330
 331         my $create_statement = "";
 332         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 333             join( ",\n",
 334                 map { "  $_" } @field_defs, @constraint_defs
 335             ).
 336             "\n);"
 337         ;
 338
 339         $output .= join( "\n\n",
 340             @comments,
 341             $create_statement,
 342             @index_defs,
 343             ''
 344         );
 345     }
 346
 347     # Text of view is already a 'create view' statement so no need to
 348     # be fancy
 349     foreach ( $schema->get_views ) {
 350         my $name = $_->name();
 351         $output .= "\n\n";
 352         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 353         my $text = $_->sql();
 354                 $text =~ s/\r//g;
 355         $output .= "$text\nGO\n";
 356     }
 357
 358     # Text of procedure already has the 'create procedure' stuff
 359     # so there is no need to do anything fancy. However, we should
 360     # think about doing fancy stuff with granting permissions and
 361     # so on.
 362     foreach ( $schema->get_procedures ) {
 363         my $name = $_->name();
 364         $output .= "\n\n";
 365         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 366         my $text = $_->sql();
 367                 $text =~ s/\r//g;
 368         $output .= "$text\nGO\n";
 369     }
 370
 371     # Warn out how we messed with the names.
 372     if ( $WARN ) {
 373         if ( %truncated ) {
 374             warn "Truncated " . keys( %truncated ) . " names:\n";
 375             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 376         }
 377         if ( %unreserve ) {
 378             warn "Encounted " . keys( %unreserve ) .
 379                 " unsafe names in schema (reserved or invalid):\n";
 380             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 381         }
 382     }
 383
 384     return $output;
 385 }
 386
 387 # -------------------------------------------------------------------
 388 sub mk_name {
 389     my $basename      = shift || '';
 390     my $type          = shift || '';
 391     my $scope         = shift || '';
 392     my $critical      = shift || '';
 393     my $basename_orig = $basename;
 394     my $max_name      = $type
 395                         ? $max_id_length - (length($type) + 1)
 396                         : $max_id_length;
 397     $basename         = substr( $basename, 0, $max_name )
 398                         if length( $basename ) > $max_name;
 399     my $name          = $type ? "${type}_$basename" : $basename;
 400
 401     if ( $basename ne $basename_orig and $critical ) {
 402         my $show_type = $type ? "+'$type'" : "";
 403         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 404             "character limit to make '$name'\n" if $WARN;
 405         $truncated{ $basename_orig } = $name;
 406     }
 407
 408     $scope ||= \%global_names;
 409     if ( my $prev = $scope->{ $name } ) {
 410         my $name_orig = $name;
 411         $name        .= sprintf( "%02d", ++$prev );
 412         substr($name, $max_id_length - 3) = "00"
 413             if length( $name ) > $max_id_length;
 414
 415         warn "The name '$name_orig' has been changed to ",
 416              "'$name' to make it unique.\n" if $WARN;
 417
 418         $scope->{ $name_orig }++;
 419     }
 420     $name = substr( $name, 0, $max_id_length )
 421                         if ((length( $name ) > $max_id_length) && $critical);
 422     $scope->{ $name }++;
 423     return $name;
 424 }
 425
 426 # -------------------------------------------------------------------
 427 sub unreserve {
 428     my $name            = shift || '';
 429     my $schema_obj_name = shift || '';
 430     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 431
 432     # also trap fields that don't begin with a letter
 433     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 434
 435     if ( $schema_obj_name ) {
 436         ++$unreserve{"$schema_obj_name.$name"};
 437     }
 438     else {
 439         ++$unreserve{"$name (table name)"};
 440     }
 441
 442     my $unreserve = sprintf '%s_', $name;
 443     return $unreserve.$suffix;
 444 }
 445
 446 1;
 447
 448 # -------------------------------------------------------------------
 449
 450 =pod
 451
 452 =head1 SEE ALSO
 453
 454 SQL::Translator.
 455
 456 =head1 AUTHORS
 457
 458 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 459 Sybase producer, I just tweaked it for SQLServer. Thanks.
 460
 461 =cut