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
 112 =pod
 113
 114 =head1 SQLServer Create Table Syntax
 115
 116 TODO
 117
 118 =cut
 119
 120 # -------------------------------------------------------------------
 121 sub produce {
 122     my $translator     = shift;
 123     $DEBUG             = $translator->debug;
 124     $WARN              = $translator->show_warnings;
 125     my $no_comments    = $translator->no_comments;
 126     my $add_drop_table = $translator->add_drop_table;
 127     my $schema         = $translator->schema;
 128
 129     %global_names = (); #reset
 130
 131     my $output;
 132     $output .= header_comment."\n" unless ($no_comments);
 133
 134     # Generate the DROP statements. We do this in one block here as if we
 135     # have fkeys we need to drop in the correct order otherwise they will fail
 136     # due to the dependancies the fkeys setup. (There is no way to turn off
 137     # fkey checking while we sort the schema like MySQL's set
 138     # foreign_key_checks=0)
 139     # We assume the tables are in the correct order to set them up as you need
 140     # to have created a table to fkey to it. So the reverse order should drop
 141     # them properly, fingers crossed...
 142     if ($add_drop_table) {
 143         $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
 144         foreach my $table (
 145             sort { $b->order <=> $a->order } $schema->get_tables
 146         ) {
 147             my $name = unreserve($table->name);
 148             $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n}
 149         }
 150     }
 151
 152     # Generate the CREATE sql
 153
 154     my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
 155
 156     for my $table ( $schema->get_tables ) {
 157         my $table_name    = $table->name or next;
 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    = $field->name;
 173             my $field_name_ur = unreserve( $field_name, $table_name );
 174             my $field_def     = qq["$field_name_ur"];
 175             $field_def        =~ s/\"//g;
 176             if ( $field_def =~ /identity/ ){
 177                 $field_def =~ s/identity/pidentity/;
 178             }
 179
 180             #
 181             # Datatype
 182             #
 183             my $data_type      = lc $field->data_type;
 184             my $orig_data_type = $data_type;
 185             my %extra          = $field->extra;
 186             my $list           = $extra{'list'} || [];
 187             # \todo deal with embedded quotes
 188             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 189
 190             if ( $data_type eq 'enum' ) {
 191                 my $check_name = mk_name( $field_name . '_chk' );
 192                 push @constraint_defs,
 193                   "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 194                 $data_type .= 'character varying';
 195             }
 196             elsif ( $data_type eq 'set' ) {
 197                 $data_type .= 'character varying';
 198             }
 199             elsif ( grep { $data_type eq $_ } qw/bytea blob clob/ ) {
 200                 $data_type = 'varbinary';
 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             SQL::Translator::Producer->_apply_default_value(
 255               $field,
 256               \$field_def,
 257               [
 258                 'NULL'       => \'NULL',
 259               ],
 260             );
 261
 262             push @field_defs, $field_def;
 263         }
 264
 265         #
 266         # Constraint Declarations
 267         #
 268         my @constraint_decs = ();
 269         for my $constraint ( $table->get_constraints ) {
 270             my $name    = $constraint->name || '';
 271             # Make sure we get a unique name
 272             my $type    = $constraint->type || NORMAL;
 273             my @fields  = map { unreserve( $_, $table_name ) }
 274                 $constraint->fields;
 275             my @rfields = map { unreserve( $_, $table_name ) }
 276                 $constraint->reference_fields;
 277             next unless @fields;
 278
 279             my $c_def;
 280             if ( $type eq FOREIGN_KEY ) {
 281                 $name ||= mk_name( $table_name . '_fk' );
 282                 my $on_delete = uc ($constraint->on_delete || '');
 283                 my $on_update = uc ($constraint->on_update || '');
 284
 285                 # The default implicit constraint action in MSSQL is RESTRICT
 286                 # but you can not specify it explicitly. Go figure :)
 287                 for ($on_delete, $on_update) {
 288                   undef $_ if $_ eq 'RESTRICT'
 289                 }
 290
 291                 $c_def =
 292                     "ALTER TABLE $table_name ADD CONSTRAINT $name FOREIGN KEY".
 293                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 294                     $constraint->reference_table.
 295                     ' (' . join( ', ', @rfields ) . ')'
 296                 ;
 297
 298                 if ( $on_delete && $on_delete ne "NO ACTION") {
 299                   $c_def .= " ON DELETE $on_delete";
 300                 }
 301                 if ( $on_update && $on_update ne "NO ACTION") {
 302                   $c_def .= " ON UPDATE $on_update";
 303                 }
 304
 305                 $c_def .= ";";
 306
 307                 push @foreign_constraints, $c_def;
 308                 next;
 309             }
 310
 311
 312             if ( $type eq PRIMARY_KEY ) {
 313                 $name ||= mk_name( $table_name . '_pk' );
 314                 $c_def =
 315                     "CONSTRAINT $name PRIMARY KEY ".
 316                     '(' . join( ', ', @fields ) . ')';
 317             }
 318             elsif ( $type eq UNIQUE ) {
 319                 $name ||= mk_name( $table_name . '_uc' );
 320                 $c_def =
 321                     "CONSTRAINT $name UNIQUE " .
 322                     '(' . join( ', ', @fields ) . ')';
 323             }
 324             push @constraint_defs, $c_def;
 325         }
 326
 327         #
 328         # Indices
 329         #
 330         for my $index ( $table->get_indices ) {
 331             my $idx_name = $index->name || mk_name($table_name . '_idx');
 332             push @index_defs,
 333                 "CREATE INDEX $idx_name ON $table_name (".
 334                 join( ', ', $index->fields ) . ");";
 335         }
 336
 337         my $create_statement = "";
 338         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 339             join( ",\n",
 340                 map { "  $_" } @field_defs, @constraint_defs
 341             ).
 342             "\n);"
 343         ;
 344
 345         $output .= join( "\n\n",
 346             @comments,
 347             $create_statement,
 348             @index_defs,
 349         );
 350     }
 351
 352 # Add FK constraints
 353     $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
 354
 355 # create view/procedure are NOT prepended to the input $sql, needs
 356 # to be filled in with the proper syntax
 357
 358 =pod
 359
 360     # Text of view is already a 'create view' statement so no need to
 361     # be fancy
 362     foreach ( $schema->get_views ) {
 363         my $name = $_->name();
 364         $output .= "\n\n";
 365         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 366         my $text = $_->sql();
 367         $text =~ s/\r//g;
 368         $output .= "$text\nGO\n";
 369     }
 370
 371     # Text of procedure already has the 'create procedure' stuff
 372     # so there is no need to do anything fancy. However, we should
 373     # think about doing fancy stuff with granting permissions and
 374     # so on.
 375     foreach ( $schema->get_procedures ) {
 376         my $name = $_->name();
 377         $output .= "\n\n";
 378         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 379         my $text = $_->sql();
 380                 $text =~ s/\r//g;
 381         $output .= "$text\nGO\n";
 382     }
 383 =cut
 384
 385     return $output;
 386 }
 387
 388 # -------------------------------------------------------------------
 389 sub mk_name {
 390     my ($name, $scope, $critical) = @_;
 391
 392     $scope ||= \%global_names;
 393     if ( my $prev = $scope->{ $name } ) {
 394         my $name_orig = $name;
 395         $name        .= sprintf( "%02d", ++$prev );
 396         substr($name, $max_id_length - 3) = "00"
 397             if length( $name ) > $max_id_length;
 398
 399         warn "The name '$name_orig' has been changed to ",
 400              "'$name' to make it unique.\n" if $WARN;
 401
 402         $scope->{ $name_orig }++;
 403     }
 404     $name = substr( $name, 0, $max_id_length )
 405                         if ((length( $name ) > $max_id_length) && $critical);
 406     $scope->{ $name }++;
 407     return $name;
 408 }
 409
 410 # -------------------------------------------------------------------
 411 sub unreserve {
 412     my $name            = shift || '';
 413     my $schema_obj_name = shift || '';
 414     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 415
 416     # also trap fields that don't begin with a letter
 417     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 418
 419     my $unreserve = sprintf '%s_', $name;
 420     return $unreserve.$suffix;
 421 }
 422
 423 1;
 424
 425 # -------------------------------------------------------------------
 426
 427 =pod
 428
 429 =head1 SEE ALSO
 430
 431 SQL::Translator.
 432
 433 =head1 AUTHORS
 434
 435 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 436 Sybase producer, I just tweaked it for SQLServer. Thanks.
 437
 438 =cut