lib/SQL/Translator/Producer/SQLServer.pm

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