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