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
 156     my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
 157
 158     for my $table ( $schema->get_tables ) {
 159         my $table_name    = $table->name or next;
 160         my $table_name_ur = unreserve($table_name) || '';
 161
 162         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 163
 164         push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
 165         unless $no_comments;
 166
 167         push @comments, map { "-- $_" } $table->comments;
 168
 169         #
 170         # Fields
 171         #
 172         my %field_name_scope;
 173         for my $field ( $table->get_fields ) {
 174             my $field_name    = $field->name;
 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( $field_name . '_chk' );
 194                 push @constraint_defs,
 195                   "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 196                 $data_type .= 'character varying';
 197             }
 198             elsif ( $data_type eq 'set' ) {
 199                 $data_type .= 'character varying';
 200             }
 201             elsif ( grep { $data_type eq $_ } qw/bytea blob clob/ ) {
 202                 $data_type = 'varbinary';
 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             SQL::Translator::Producer->_apply_default_value(
 257               $field,
 258               \$field_def,
 259               [
 260                 'NULL'       => \'NULL',
 261               ],
 262             );
 263
 264             push @field_defs, $field_def;
 265         }
 266
 267         #
 268         # Constraint Declarations
 269         #
 270         my @constraint_decs = ();
 271         for my $constraint ( $table->get_constraints ) {
 272             my $name    = $constraint->name || '';
 273             # Make sure we get a unique name
 274             my $type    = $constraint->type || NORMAL;
 275             my @fields  = map { unreserve( $_, $table_name ) }
 276                 $constraint->fields;
 277             my @rfields = map { unreserve( $_, $table_name ) }
 278                 $constraint->reference_fields;
 279             next unless @fields;
 280
 281             my $c_def;
 282             if ( $type eq FOREIGN_KEY ) {
 283                 $name ||= mk_name( $table_name . '_fk' );
 284                 my $on_delete = uc ($constraint->on_delete || '');
 285                 my $on_update = uc ($constraint->on_update || '');
 286
 287                 # The default implicit constraint action in MSSQL is RESTRICT
 288                 # but you can not specify it explicitly. Go figure :)
 289                 for ($on_delete, $on_update) {
 290                   undef $_ if $_ eq 'RESTRICT'
 291                 }
 292
 293                 $c_def =
 294                     "ALTER TABLE $table_name ADD CONSTRAINT $name FOREIGN KEY".
 295                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 296                     $constraint->reference_table.
 297                     ' (' . join( ', ', @rfields ) . ')'
 298                 ;
 299
 300                 if ( $on_delete && $on_delete ne "NO ACTION") {
 301                   $c_def .= " ON DELETE $on_delete";
 302                 }
 303                 if ( $on_update && $on_update ne "NO ACTION") {
 304                   $c_def .= " ON UPDATE $on_update";
 305                 }
 306
 307                 $c_def .= ";";
 308
 309                 push @foreign_constraints, $c_def;
 310                 next;
 311             }
 312
 313
 314             if ( $type eq PRIMARY_KEY ) {
 315                 $name ||= mk_name( $table_name . '_pk' );
 316                 $c_def =
 317                     "CONSTRAINT $name PRIMARY KEY ".
 318                     '(' . join( ', ', @fields ) . ')';
 319             }
 320             elsif ( $type eq UNIQUE ) {
 321                 $name ||= mk_name( $table_name . '_uc' );
 322                 $c_def =
 323                     "CONSTRAINT $name UNIQUE " .
 324                     '(' . join( ', ', @fields ) . ')';
 325             }
 326             push @constraint_defs, $c_def;
 327         }
 328
 329         #
 330         # Indices
 331         #
 332         for my $index ( $table->get_indices ) {
 333             my $idx_name = $index->name || mk_name($table_name . '_idx');
 334             push @index_defs,
 335                 "CREATE INDEX $idx_name ON $table_name (".
 336                 join( ', ', $index->fields ) . ");";
 337         }
 338
 339         my $create_statement = "";
 340         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 341             join( ",\n",
 342                 map { "  $_" } @field_defs, @constraint_defs
 343             ).
 344             "\n);"
 345         ;
 346
 347         $output .= join( "\n\n",
 348             @comments,
 349             $create_statement,
 350             @index_defs,
 351         );
 352     }
 353
 354 # Add FK constraints
 355     $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
 356
 357 # create view/procedure are NOT prepended to the input $sql, needs
 358 # to be filled in with the proper syntax
 359
 360 =pod
 361
 362     # Text of view is already a 'create view' statement so no need to
 363     # be fancy
 364     foreach ( $schema->get_views ) {
 365         my $name = $_->name();
 366         $output .= "\n\n";
 367         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 368         my $text = $_->sql();
 369         $text =~ s/\r//g;
 370         $output .= "$text\nGO\n";
 371     }
 372
 373     # Text of procedure already has the 'create procedure' stuff
 374     # so there is no need to do anything fancy. However, we should
 375     # think about doing fancy stuff with granting permissions and
 376     # so on.
 377     foreach ( $schema->get_procedures ) {
 378         my $name = $_->name();
 379         $output .= "\n\n";
 380         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 381         my $text = $_->sql();
 382                 $text =~ s/\r//g;
 383         $output .= "$text\nGO\n";
 384     }
 385 =cut
 386
 387     return $output;
 388 }
 389
 390 # -------------------------------------------------------------------
 391 sub mk_name {
 392     my ($name, $scope, $critical) = @_;
 393
 394     $scope ||= \%global_names;
 395     if ( my $prev = $scope->{ $name } ) {
 396         my $name_orig = $name;
 397         $name        .= sprintf( "%02d", ++$prev );
 398         substr($name, $max_id_length - 3) = "00"
 399             if length( $name ) > $max_id_length;
 400
 401         warn "The name '$name_orig' has been changed to ",
 402              "'$name' to make it unique.\n" if $WARN;
 403
 404         $scope->{ $name_orig }++;
 405     }
 406     $name = substr( $name, 0, $max_id_length )
 407                         if ((length( $name ) > $max_id_length) && $critical);
 408     $scope->{ $name }++;
 409     return $name;
 410 }
 411
 412 # -------------------------------------------------------------------
 413 sub unreserve {
 414     my $name            = shift || '';
 415     my $schema_obj_name = shift || '';
 416     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 417
 418     # also trap fields that don't begin with a letter
 419     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 420
 421     if ( $schema_obj_name ) {
 422         ++$unreserve{"$schema_obj_name.$name"};
 423     }
 424     else {
 425         ++$unreserve{"$name (table name)"};
 426     }
 427
 428     my $unreserve = sprintf '%s_', $name;
 429     return $unreserve.$suffix;
 430 }
 431
 432 1;
 433
 434 # -------------------------------------------------------------------
 435
 436 =pod
 437
 438 =head1 SEE ALSO
 439
 440 SQL::Translator.
 441
 442 =head1 AUTHORS
 443
 444 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 445 Sybase producer, I just tweaked it for SQLServer. Thanks.
 446
 447 =cut