lib/SQL/Translator/Producer/SQLServer.pm

   1 package SQL::Translator::Producer::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLServer.pm,v 1.5 2006-05-05 16:41:26 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.5 $ =~ /(\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             my $seq_name;
 193
 194             if ( $data_type eq 'enum' ) {
 195                 my $check_name = mk_name(
 196                     $table_name.'_'.$field_name, 'chk' ,undef, 1
 197                 );
 198                 push @constraint_defs,
 199                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 200                 $data_type .= 'character varying';
 201             }
 202             elsif ( $data_type eq 'set' ) {
 203                 $data_type .= 'character varying';
 204             }
 205             else {
 206                 if ( defined $translate{ $data_type } ) {
 207                     $data_type = $translate{ $data_type };
 208                 }
 209                 else {
 210                     warn "Unknown datatype: $data_type ",
 211                         "($table_name.$field_name)\n" if $WARN;
 212                 }
 213             }
 214
 215             my $size = $field->size;
 216             if ( grep $_ eq $data_type, @no_size) {
 217             # SQLServer doesn't seem to like sizes on some datatypes
 218                 $size = undef;
 219             }
 220             elsif ( !$size ) {
 221                 if ( $data_type =~ /numeric/ ) {
 222                     $size = '9,0';
 223                 }
 224                 elsif ( $orig_data_type eq 'text' ) {
 225                     #interpret text fields as long varchars
 226                     $size = '255';
 227                 }
 228                 elsif (
 229                     $data_type eq 'varchar' &&
 230                     $orig_data_type eq 'boolean'
 231                 ) {
 232                     $size = '6';
 233                 }
 234                 elsif ( $data_type eq 'varchar' ) {
 235                     $size = '255';
 236                 }
 237             }
 238
 239             $field_def .= " $data_type";
 240             $field_def .= "($size)" if $size;
 241
 242             $field_def .= ' IDENTITY' if $field->is_auto_increment;
 243
 244             #
 245             # Not null constraint
 246             #
 247             unless ( $field->is_nullable ) {
 248                 $field_def .= ' NOT NULL';
 249             }
 250             else {
 251                 $field_def .= ' NULL' if $data_type ne 'bit';
 252             }
 253
 254             #
 255             # Default value
 256             #
 257             my $default = $field->default_value;
 258             if ( defined $default ) {
 259                 $field_def .= sprintf( ' DEFAULT %s',
 260                     ( $field->is_auto_increment && $seq_name )
 261                     ? qq[nextval('"$seq_name"'::text)] :
 262                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 263                 );
 264             }
 265
 266             push @field_defs, $field_def;
 267         }
 268
 269         #
 270         # Constraint Declarations
 271         #
 272         my @constraint_decs = ();
 273         my $c_name_default;
 274         for my $constraint ( $table->get_constraints ) {
 275             my $name    = $constraint->name || '';
 276             # Make sure we get a unique name
 277             $name       = mk_name( $name, undef, undef, 1 ) if $name;
 278             my $type    = $constraint->type || NORMAL;
 279             my @fields  = map { unreserve( $_, $table_name ) }
 280                 $constraint->fields;
 281             my @rfields = map { unreserve( $_, $table_name ) }
 282                 $constraint->reference_fields;
 283             next unless @fields;
 284
 285                         my $c_def;
 286             if ( $type eq PRIMARY_KEY ) {
 287                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 288                 $c_def =
 289                     "CONSTRAINT $name PRIMARY KEY ".
 290                     '(' . join( ', ', @fields ) . ')';
 291             }
 292             elsif ( $type eq FOREIGN_KEY ) {
 293                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 294                 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
 295                 $c_def =
 296                     "CONSTRAINT $name FOREIGN KEY".
 297                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 298                     $constraint->reference_table.
 299                     ' (' . join( ', ', @rfields ) . ')';
 300                  my $on_delete = $constraint->on_delete;
 301                  if ( defined $on_delete && $on_delete ne "NO ACTION") {
 302                         $c_def .= " ON DELETE $on_delete";
 303                  }
 304                  my $on_update = $constraint->on_update;
 305                  if ( defined $on_update && $on_update ne "NO ACTION") {
 306                         $c_def .= " ON UPDATE $on_update";
 307                  }
 308             }
 309             elsif ( $type eq UNIQUE ) {
 310                 $name ||= mk_name(
 311                     $table_name,
 312                     $name || ++$c_name_default,undef, 1
 313                 );
 314                 $c_def =
 315                     "CONSTRAINT $name UNIQUE " .
 316                     '(' . join( ', ', @fields ) . ')';
 317             }
 318             push @constraint_defs, $c_def;
 319         }
 320
 321         #
 322         # Indices
 323         #
 324         for my $index ( $table->get_indices ) {
 325             my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
 326             push @index_defs,
 327                 "CREATE INDEX $idx_name ON $table_name (".
 328                 join( ', ', $index->fields ) . ");";
 329         }
 330
 331         my $create_statement = "";
 332         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 333             join( ",\n",
 334                 map { "  $_" } @field_defs, @constraint_defs
 335             ).
 336             "\n);"
 337         ;
 338
 339         $output .= join( "\n\n",
 340             @comments,
 341             $create_statement,
 342             @index_defs,
 343             ''
 344         );
 345     }
 346
 347     # Text of view is already a 'create view' statement so no need to
 348     # be fancy
 349     foreach ( $schema->get_views ) {
 350         my $name = $_->name();
 351         $output .= "\n\n";
 352         $output .= "--\n-- View: $name\n--" unless $no_comments;
 353         my $text = $_->sql();
 354                 $text =~ s/\r//g;
 355         $output .= $text;
 356     }
 357
 358     # Text of procedure already has the 'create procedure' stuff
 359     # so there is no need to do anything fancy. However, we should
 360     # think about doing fancy stuff with granting permissions and
 361     # so on.
 362     foreach ( $schema->get_procedures ) {
 363         my $name = $_->name();
 364         $output .= "\n\n";
 365         $output .= "--\n-- Procedure: $name\n--" unless $no_comments;
 366         my $text = $_->sql();
 367                 $text =~ s/\r//g;
 368         $output .= $text;
 369     }
 370
 371     # Warn out how we messed with the names.
 372     if ( $WARN ) {
 373         if ( %truncated ) {
 374             warn "Truncated " . keys( %truncated ) . " names:\n";
 375             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 376         }
 377         if ( %unreserve ) {
 378             warn "Encounted " . keys( %unreserve ) .
 379                 " unsafe names in schema (reserved or invalid):\n";
 380             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 381         }
 382     }
 383
 384     return $output;
 385 }
 386
 387 # -------------------------------------------------------------------
 388 sub mk_name {
 389     my $basename      = shift || '';
 390     my $type          = shift || '';
 391     my $scope         = shift || '';
 392     my $critical      = shift || '';
 393     my $basename_orig = $basename;
 394     my $max_name      = $type
 395                         ? $max_id_length - (length($type) + 1)
 396                         : $max_id_length;
 397     $basename         = substr( $basename, 0, $max_name )
 398                         if length( $basename ) > $max_name;
 399     my $name          = $type ? "${type}_$basename" : $basename;
 400
 401     if ( $basename ne $basename_orig and $critical ) {
 402         my $show_type = $type ? "+'$type'" : "";
 403         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 404             "character limit to make '$name'\n" if $WARN;
 405         $truncated{ $basename_orig } = $name;
 406     }
 407
 408     $scope ||= \%global_names;
 409     if ( my $prev = $scope->{ $name } ) {
 410         my $name_orig = $name;
 411         $name        .= sprintf( "%02d", ++$prev );
 412         substr($name, $max_id_length - 3) = "00"
 413             if length( $name ) > $max_id_length;
 414
 415         warn "The name '$name_orig' has been changed to ",
 416              "'$name' to make it unique.\n" if $WARN;
 417
 418         $scope->{ $name_orig }++;
 419     }
 420     $name = substr( $name, 0, $max_id_length )
 421                         if ((length( $name ) > $max_id_length) && $critical);
 422     $scope->{ $name }++;
 423     return $name;
 424 }
 425
 426 # -------------------------------------------------------------------
 427 sub unreserve {
 428     my $name            = shift || '';
 429     my $schema_obj_name = shift || '';
 430     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 431
 432     # also trap fields that don't begin with a letter
 433     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 434
 435     if ( $schema_obj_name ) {
 436         ++$unreserve{"$schema_obj_name.$name"};
 437     }
 438     else {
 439         ++$unreserve{"$name (table name)"};
 440     }
 441
 442     my $unreserve = sprintf '%s_', $name;
 443     return $unreserve.$suffix;
 444 }
 445
 446 1;
 447
 448 # -------------------------------------------------------------------
 449
 450 =pod
 451
 452 =head1 SEE ALSO
 453
 454 SQL::Translator.
 455
 456 =head1 AUTHORS
 457
 458 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 459 Sybase producer, I just tweaked it for SQLServer. Thanks.
 460
 461 =cut