lib/SQL/Translator/Producer/SQLServer.pm

   1 package SQL::Translator::Producer::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLServer.pm,v 1.4 2006-05-04 20:46:45 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.4 $ =~ /(\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             if ( $type eq PRIMARY_KEY ) {
 286                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 287                 push @constraint_defs,
 288                     "CONSTRAINT $name PRIMARY KEY ".
 289                     '(' . join( ', ', @fields ) . ')';
 290             }
 291             elsif ( $type eq FOREIGN_KEY ) {
 292                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 293                 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
 294                 push @constraint_defs,
 295                     "CONSTRAINT $name FOREIGN KEY".
 296                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 297                     $constraint->reference_table.
 298                     ' (' . join( ', ', @rfields ) . ')';
 299             }
 300             elsif ( $type eq UNIQUE ) {
 301                 $name ||= mk_name(
 302                     $table_name,
 303                     $name || ++$c_name_default,undef, 1
 304                 );
 305                 push @constraint_defs,
 306                     "CONSTRAINT $name UNIQUE " .
 307                     '(' . join( ', ', @fields ) . ')';
 308             }
 309         }
 310
 311         #
 312         # Indices
 313         #
 314         for my $index ( $table->get_indices ) {
 315             my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
 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
 337     # Text of view is already a 'create view' statement so no need to
 338     # be fancy
 339     foreach ( $schema->get_views ) {
 340         my $name = $_->name();
 341         $output .= "\n\n";
 342         $output .= "--\n-- View: $name\n--" unless $no_comments;
 343         my $text = $_->sql();
 344                 $text =~ s/\r//g;
 345         $output .= $text;
 346     }
 347
 348     # Text of procedure already has the 'create procedure' stuff
 349     # so there is no need to do anything fancy. However, we should
 350     # think about doing fancy stuff with granting permissions and
 351     # so on.
 352     foreach ( $schema->get_procedures ) {
 353         my $name = $_->name();
 354         $output .= "\n\n";
 355         $output .= "--\n-- Procedure: $name\n--" unless $no_comments;
 356         my $text = $_->sql();
 357                 $text =~ s/\r//g;
 358         $output .= $text;
 359     }
 360
 361     # Warn out how we messed with the names.
 362     if ( $WARN ) {
 363         if ( %truncated ) {
 364             warn "Truncated " . keys( %truncated ) . " names:\n";
 365             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 366         }
 367         if ( %unreserve ) {
 368             warn "Encounted " . keys( %unreserve ) .
 369                 " unsafe names in schema (reserved or invalid):\n";
 370             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 371         }
 372     }
 373
 374     return $output;
 375 }
 376
 377 # -------------------------------------------------------------------
 378 sub mk_name {
 379     my $basename      = shift || '';
 380     my $type          = shift || '';
 381     my $scope         = shift || '';
 382     my $critical      = shift || '';
 383     my $basename_orig = $basename;
 384     my $max_name      = $type
 385                         ? $max_id_length - (length($type) + 1)
 386                         : $max_id_length;
 387     $basename         = substr( $basename, 0, $max_name )
 388                         if length( $basename ) > $max_name;
 389     my $name          = $type ? "${type}_$basename" : $basename;
 390
 391     if ( $basename ne $basename_orig and $critical ) {
 392         my $show_type = $type ? "+'$type'" : "";
 393         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 394             "character limit to make '$name'\n" if $WARN;
 395         $truncated{ $basename_orig } = $name;
 396     }
 397
 398     $scope ||= \%global_names;
 399     if ( my $prev = $scope->{ $name } ) {
 400         my $name_orig = $name;
 401         $name        .= sprintf( "%02d", ++$prev );
 402         substr($name, $max_id_length - 3) = "00"
 403             if length( $name ) > $max_id_length;
 404
 405         warn "The name '$name_orig' has been changed to ",
 406              "'$name' to make it unique.\n" if $WARN;
 407
 408         $scope->{ $name_orig }++;
 409     }
 410     $name = substr( $name, 0, $max_id_length )
 411                         if ((length( $name ) > $max_id_length) && $critical);
 412     $scope->{ $name }++;
 413     return $name;
 414 }
 415
 416 # -------------------------------------------------------------------
 417 sub unreserve {
 418     my $name            = shift || '';
 419     my $schema_obj_name = shift || '';
 420     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 421
 422     # also trap fields that don't begin with a letter
 423     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 424
 425     if ( $schema_obj_name ) {
 426         ++$unreserve{"$schema_obj_name.$name"};
 427     }
 428     else {
 429         ++$unreserve{"$name (table name)"};
 430     }
 431
 432     my $unreserve = sprintf '%s_', $name;
 433     return $unreserve.$suffix;
 434 }
 435
 436 1;
 437
 438 # -------------------------------------------------------------------
 439
 440 =pod
 441
 442 =head1 SEE ALSO
 443
 444 SQL::Translator.
 445
 446 =head1 AUTHORS
 447
 448 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 449 Sybase producer, I just tweaked it for SQLServer. Thanks.
 450
 451 =cut