lib/SQL/Translator/Producer/SQLServer.pm

   1 package SQL::Translator::Producer::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLServer.pm,v 1.7 2007-03-14 16:56:33 duality72 Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-4 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 $VERSION ];
  59 $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
  60 $DEBUG = 1 unless defined $DEBUG;
  61
  62 use Data::Dumper;
  63 use SQL::Translator::Schema::Constants;
  64 use SQL::Translator::Utils qw(debug header_comment);
  65
  66 my %translate  = (
  67     date      => 'datetime',
  68     'time'    => 'datetime',
  69     # Sybase types
  70     #integer   => 'numeric',
  71     #int       => 'numeric',
  72     #number    => 'numeric',
  73     #money     => 'money',
  74     #varchar   => 'varchar',
  75     #varchar2  => 'varchar',
  76     #timestamp => 'datetime',
  77     #text      => 'varchar',
  78     #real      => 'double precision',
  79     #comment   => 'text',
  80     #bit       => 'bit',
  81     #tinyint   => 'smallint',
  82     #float     => 'double precision',
  83     #serial    => 'numeric',
  84     #boolean   => 'varchar',
  85     #char      => 'char',
  86     #long      => 'varchar',
  87 );
  88
  89 # TODO - This is still the Sybase list!
  90 my %reserved = map { $_, 1 } qw[
  91     ALL ANALYSE ANALYZE AND ANY AS ASC
  92     BETWEEN BINARY BOTH
  93     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  94     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  95     DEFAULT DEFERRABLE DESC DISTINCT DO
  96     ELSE END EXCEPT
  97     FALSE FOR FOREIGN FREEZE FROM FULL
  98     GROUP HAVING
  99     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 100     JOIN LEADING LEFT LIKE LIMIT
 101     NATURAL NEW NOT NOTNULL NULL
 102     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 103     PRIMARY PUBLIC REFERENCES RIGHT
 104     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 105     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 106 ];
 107
 108 # If these datatypes have size appended the sql fails.
 109 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
 110
 111 my $max_id_length    = 128;
 112 my %used_identifiers = ();
 113 my %global_names;
 114 my %unreserve;
 115 my %truncated;
 116
 117 =pod
 118
 119 =head1 SQLServer Create Table Syntax
 120
 121 TODO
 122
 123 =cut
 124
 125 # -------------------------------------------------------------------
 126 sub produce {
 127     my $translator     = shift;
 128     $DEBUG             = $translator->debug;
 129     $WARN              = $translator->show_warnings;
 130     my $no_comments    = $translator->no_comments;
 131     my $add_drop_table = $translator->add_drop_table;
 132     my $schema         = $translator->schema;
 133
 134     my $output;
 135     $output .= header_comment."\n" unless ($no_comments);
 136
 137     # Generate the DROP statements. We do this in one block here as if we
 138     # have fkeys we need to drop in the correct order otherwise they will fail
 139     # due to the dependancies the fkeys setup. (There is no way to turn off
 140     # fkey checking while we sort the schema like MySQL's set
 141     # foreign_key_checks=0)
 142     # We assume the tables are in the correct order to set them up as you need
 143     # to have created a table to fkey to it. So the reverse order should drop
 144     # them properly, fingers crossed...
 145     if ($add_drop_table) {
 146         $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
 147         foreach my $table (
 148             sort { $b->order <=> $a->order } $schema->get_tables
 149         ) {
 150             my $name = unreserve($table->name);
 151             $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
 152         }
 153     }
 154
 155     # Generate the CREATE sql
 156     for my $table ( $schema->get_tables ) {
 157         my $table_name    = $table->name or next;
 158         $table_name       = mk_name( $table_name, '', undef, 1 );
 159         my $table_name_ur = unreserve($table_name) || '';
 160
 161         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 162
 163         push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
 164         unless $no_comments;
 165
 166         push @comments, map { "-- $_" } $table->comments;
 167
 168         #
 169         # Fields
 170         #
 171         my %field_name_scope;
 172         for my $field ( $table->get_fields ) {
 173             my $field_name    = mk_name(
 174                 $field->name, '', \%field_name_scope, undef,1
 175             );
 176             my $field_name_ur = unreserve( $field_name, $table_name );
 177             my $field_def     = qq["$field_name_ur"];
 178             $field_def        =~ s/\"//g;
 179             if ( $field_def =~ /identity/ ){
 180                 $field_def =~ s/identity/pidentity/;
 181             }
 182
 183             #
 184             # Datatype
 185             #
 186             my $data_type      = lc $field->data_type;
 187             my $orig_data_type = $data_type;
 188             my %extra          = $field->extra;
 189             my $list           = $extra{'list'} || [];
 190             # \todo deal with embedded quotes
 191             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 192
 193             if ( $data_type eq 'enum' ) {
 194                 my $check_name = mk_name(
 195                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 196                 );
 197                 push @constraint_defs,
 198                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 199                 $data_type .= 'character varying';
 200             }
 201             elsif ( $data_type eq 'set' ) {
 202                 $data_type .= 'character varying';
 203             }
 204             else {
 205                 if ( defined $translate{ $data_type } ) {
 206                     $data_type = $translate{ $data_type };
 207                 }
 208                 else {
 209                     warn "Unknown datatype: $data_type ",
 210                         "($table_name.$field_name)\n" if $WARN;
 211                 }
 212             }
 213
 214             my $size = $field->size;
 215             if ( grep $_ eq $data_type, @no_size) {
 216             # SQLServer doesn't seem to like sizes on some datatypes
 217                 $size = undef;
 218             }
 219             elsif ( !$size ) {
 220                 if ( $data_type =~ /numeric/ ) {
 221                     $size = '9,0';
 222                 }
 223                 elsif ( $orig_data_type eq 'text' ) {
 224                     #interpret text fields as long varchars
 225                     $size = '255';
 226                 }
 227                 elsif (
 228                     $data_type eq 'varchar' &&
 229                     $orig_data_type eq 'boolean'
 230                 ) {
 231                     $size = '6';
 232                 }
 233                 elsif ( $data_type eq 'varchar' ) {
 234                     $size = '255';
 235                 }
 236             }
 237
 238             $field_def .= " $data_type";
 239             $field_def .= "($size)" if $size;
 240
 241             $field_def .= ' IDENTITY' if $field->is_auto_increment;
 242
 243             #
 244             # Not null constraint
 245             #
 246             unless ( $field->is_nullable ) {
 247                 $field_def .= ' NOT NULL';
 248             }
 249             else {
 250                 $field_def .= ' NULL' if $data_type ne 'bit';
 251             }
 252
 253             #
 254             # Default value
 255             #
 256             my $default = $field->default_value;
 257             if ( defined $default ) {
 258                 SQL::Translator::Producer->_apply_default_value(
 259                   \$field_def,
 260                   $default,
 261                   [
 262                     'NULL'       => \'NULL',
 263                   ],
 264                 );
 265             }
 266
 267             push @field_defs, $field_def;
 268         }
 269
 270         #
 271         # Constraint Declarations
 272         #
 273         my @constraint_decs = ();
 274         my $c_name_default;
 275         for my $constraint ( $table->get_constraints ) {
 276             my $name    = $constraint->name || '';
 277             # Make sure we get a unique name
 278             $name       = mk_name( $name, undef, undef, 1 ) if $name;
 279             my $type    = $constraint->type || NORMAL;
 280             my @fields  = map { unreserve( $_, $table_name ) }
 281                 $constraint->fields;
 282             my @rfields = map { unreserve( $_, $table_name ) }
 283                 $constraint->reference_fields;
 284             next unless @fields;
 285
 286                         my $c_def;
 287             if ( $type eq PRIMARY_KEY ) {
 288                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 289                 $c_def =
 290                     "CONSTRAINT $name PRIMARY KEY ".
 291                     '(' . join( ', ', @fields ) . ')';
 292             }
 293             elsif ( $type eq FOREIGN_KEY ) {
 294                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 295                 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
 296                 $c_def =
 297                     "CONSTRAINT $name FOREIGN KEY".
 298                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 299                     $constraint->reference_table.
 300                     ' (' . join( ', ', @rfields ) . ')';
 301                  my $on_delete = $constraint->on_delete;
 302                  if ( defined $on_delete && $on_delete ne "NO ACTION") {
 303                         $c_def .= " ON DELETE $on_delete";
 304                  }
 305                  my $on_update = $constraint->on_update;
 306                  if ( defined $on_update && $on_update ne "NO ACTION") {
 307                         $c_def .= " ON UPDATE $on_update";
 308                  }
 309             }
 310             elsif ( $type eq UNIQUE ) {
 311                 $name ||= mk_name(
 312                     $table_name,
 313                     $name || ++$c_name_default,undef, 1
 314                 );
 315                 $c_def =
 316                     "CONSTRAINT $name UNIQUE " .
 317                     '(' . join( ', ', @fields ) . ')';
 318             }
 319             push @constraint_defs, $c_def;
 320         }
 321
 322         #
 323         # Indices
 324         #
 325         for my $index ( $table->get_indices ) {
 326             my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
 327             push @index_defs,
 328                 "CREATE INDEX $idx_name ON $table_name (".
 329                 join( ', ', $index->fields ) . ");";
 330         }
 331
 332         my $create_statement = "";
 333         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 334             join( ",\n",
 335                 map { "  $_" } @field_defs, @constraint_defs
 336             ).
 337             "\n);"
 338         ;
 339
 340         $output .= join( "\n\n",
 341             @comments,
 342             $create_statement,
 343             @index_defs,
 344             ''
 345         );
 346     }
 347
 348     # Text of view is already a 'create view' statement so no need to
 349     # be fancy
 350     foreach ( $schema->get_views ) {
 351         my $name = $_->name();
 352         $output .= "\n\n";
 353         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 354         my $text = $_->sql();
 355                 $text =~ s/\r//g;
 356         $output .= "$text\nGO\n";
 357     }
 358
 359     # Text of procedure already has the 'create procedure' stuff
 360     # so there is no need to do anything fancy. However, we should
 361     # think about doing fancy stuff with granting permissions and
 362     # so on.
 363     foreach ( $schema->get_procedures ) {
 364         my $name = $_->name();
 365         $output .= "\n\n";
 366         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 367         my $text = $_->sql();
 368                 $text =~ s/\r//g;
 369         $output .= "$text\nGO\n";
 370     }
 371
 372     # Warn out how we messed with the names.
 373     if ( $WARN ) {
 374         if ( %truncated ) {
 375             warn "Truncated " . keys( %truncated ) . " names:\n";
 376             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 377         }
 378         if ( %unreserve ) {
 379             warn "Encounted " . keys( %unreserve ) .
 380                 " unsafe names in schema (reserved or invalid):\n";
 381             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 382         }
 383     }
 384
 385     return $output;
 386 }
 387
 388 # -------------------------------------------------------------------
 389 sub mk_name {
 390     my $basename      = shift || '';
 391     my $type          = shift || '';
 392     my $scope         = shift || '';
 393     my $critical      = shift || '';
 394     my $basename_orig = $basename;
 395     my $max_name      = $type
 396                         ? $max_id_length - (length($type) + 1)
 397                         : $max_id_length;
 398     $basename         = substr( $basename, 0, $max_name )
 399                         if length( $basename ) > $max_name;
 400     my $name          = $type ? "${type}_$basename" : $basename;
 401
 402     if ( $basename ne $basename_orig and $critical ) {
 403         my $show_type = $type ? "+'$type'" : "";
 404         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 405             "character limit to make '$name'\n" if $WARN;
 406         $truncated{ $basename_orig } = $name;
 407     }
 408
 409     $scope ||= \%global_names;
 410     if ( my $prev = $scope->{ $name } ) {
 411         my $name_orig = $name;
 412         $name        .= sprintf( "%02d", ++$prev );
 413         substr($name, $max_id_length - 3) = "00"
 414             if length( $name ) > $max_id_length;
 415
 416         warn "The name '$name_orig' has been changed to ",
 417              "'$name' to make it unique.\n" if $WARN;
 418
 419         $scope->{ $name_orig }++;
 420     }
 421     $name = substr( $name, 0, $max_id_length )
 422                         if ((length( $name ) > $max_id_length) && $critical);
 423     $scope->{ $name }++;
 424     return $name;
 425 }
 426
 427 # -------------------------------------------------------------------
 428 sub unreserve {
 429     my $name            = shift || '';
 430     my $schema_obj_name = shift || '';
 431     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 432
 433     # also trap fields that don't begin with a letter
 434     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 435
 436     if ( $schema_obj_name ) {
 437         ++$unreserve{"$schema_obj_name.$name"};
 438     }
 439     else {
 440         ++$unreserve{"$name (table name)"};
 441     }
 442
 443     my $unreserve = sprintf '%s_', $name;
 444     return $unreserve.$suffix;
 445 }
 446
 447 1;
 448
 449 # -------------------------------------------------------------------
 450
 451 =pod
 452
 453 =head1 SEE ALSO
 454
 455 SQL::Translator.
 456
 457 =head1 AUTHORS
 458
 459 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 460 Sybase producer, I just tweaked it for SQLServer. Thanks.
 461
 462 =cut