lib/SQL/Translator/Producer/SQLServer.pm

   1 package SQL::Translator::Producer::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLServer.pm,v 1.1 2005-01-13 21:30:04 grommit 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.1 $ =~ /(\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/int integer bigint text bit/;
 110
 111 my $max_id_length    = 30;
 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             # Default value
 246             #
 247             my $default = $field->default_value;
 248             if ( defined $default ) {
 249                 $field_def .= sprintf( ' DEFAULT %s',
 250                     ( $field->is_auto_increment && $seq_name )
 251                     ? qq[nextval('"$seq_name"'::text)] :
 252                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 253                 );
 254             }
 255
 256             #
 257             # Not null constraint
 258             #
 259             unless ( $field->is_nullable ) {
 260                 $field_def .= ' NOT NULL';
 261             }
 262             else {
 263                 $field_def .= ' NULL' if $data_type ne 'bit';
 264             }
 265             push @field_defs, $field_def;
 266         }
 267
 268         #
 269         # Constraint Declarations
 270         #
 271         my @constraint_decs = ();
 272         my $c_name_default;
 273         for my $constraint ( $table->get_constraints ) {
 274             my $name    = $constraint->name || '';
 275             # Make sure we get a unique name
 276             $name       = mk_name( $name, undef, undef, 1 ) if $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             if ( $type eq PRIMARY_KEY ) {
 285                 $name ||= mk_name( $table_name, 'pk', undef,1 );
 286                 push @constraint_defs,
 287                     "CONSTRAINT $name PRIMARY KEY ".
 288                     '(' . join( ', ', @fields ) . ')';
 289             }
 290             elsif ( $type eq FOREIGN_KEY ) {
 291                 $name ||= mk_name( $table_name, 'fk', undef,1 );
 292                 #$name = mk_name( ($name || $table_name), 'fk', undef,1 );
 293                 push @constraint_defs,
 294                     "CONSTRAINT $name FOREIGN KEY".
 295                     ' (' . join( ', ', @fields ) . ') REFERENCES '.
 296                     $constraint->reference_table.
 297                     ' (' . join( ', ', @rfields ) . ')';
 298             }
 299             elsif ( $type eq UNIQUE ) {
 300                 $name ||= mk_name(
 301                     $table_name,
 302                     $name || ++$c_name_default,undef, 1
 303                 );
 304                 push @constraint_defs,
 305                     "CONSTRAINT $name UNIQUE " .
 306                     '(' . join( ', ', @fields ) . ')';
 307             }
 308         }
 309
 310         #
 311         # Indices
 312         #
 313         for my $index ( $table->get_indices ) {
 314             my $idx_name = $index->name || mk_name($table_name,'idx',undef,1);
 315             push @index_defs,
 316                 "CREATE INDEX $idx_name ON $table_name (".
 317                 join( ', ', $index->fields ) . ");";
 318         }
 319
 320         my $create_statement = "";
 321         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 322             join( ",\n",
 323                 map { "  $_" } @field_defs, @constraint_defs
 324             ).
 325             "\n);"
 326         ;
 327
 328         $output .= join( "\n\n",
 329             @comments,
 330             $create_statement,
 331             @index_defs,
 332             ''
 333         );
 334     }
 335
 336     # Text of view is already a 'create view' statement so no need to
 337     # be fancy
 338     foreach ( $schema->get_views ) {
 339         my $name = $_->name();
 340         $output .= "\n\n";
 341         $output .= "--\n-- View: $name\n--" unless $no_comments;
 342         $output .= $_->sql();
 343     }
 344
 345     # Text of procedure already has the 'create procedure' stuff
 346     # so there is no need to do anything fancy. However, we should
 347     # think about doing fancy stuff with granting permissions and
 348     # so on.
 349     foreach ( $schema->get_procedures ) {
 350         my $name = $_->name();
 351         $output .= "\n\n";
 352         $output .= "--\n-- Procedure: $name\n--" unless $no_comments;
 353         $output .= $_->sql();
 354     }
 355
 356     # Warn out how we messed with the names.
 357     if ( $WARN ) {
 358         if ( %truncated ) {
 359             warn "Truncated " . keys( %truncated ) . " names:\n";
 360             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 361         }
 362         if ( %unreserve ) {
 363             warn "Encounted " . keys( %unreserve ) .
 364                 " unsafe names in schema (reserved or invalid):\n";
 365             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 366         }
 367     }
 368
 369     return $output;
 370 }
 371
 372 # -------------------------------------------------------------------
 373 sub mk_name {
 374     my $basename      = shift || '';
 375     my $type          = shift || '';
 376     my $scope         = shift || '';
 377     my $critical      = shift || '';
 378     my $basename_orig = $basename;
 379     my $max_name      = $type
 380                         ? $max_id_length - (length($type) + 1)
 381                         : $max_id_length;
 382     $basename         = substr( $basename, 0, $max_name )
 383                         if length( $basename ) > $max_name;
 384     my $name          = $type ? "${type}_$basename" : $basename;
 385
 386     if ( $basename ne $basename_orig and $critical ) {
 387         my $show_type = $type ? "+'$type'" : "";
 388         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 389             "character limit to make '$name'\n" if $WARN;
 390         $truncated{ $basename_orig } = $name;
 391     }
 392
 393     $scope ||= \%global_names;
 394     if ( my $prev = $scope->{ $name } ) {
 395         my $name_orig = $name;
 396         $name        .= sprintf( "%02d", ++$prev );
 397         substr($name, $max_id_length - 3) = "00"
 398             if length( $name ) > $max_id_length;
 399
 400         warn "The name '$name_orig' has been changed to ",
 401              "'$name' to make it unique.\n" if $WARN;
 402
 403         $scope->{ $name_orig }++;
 404     }
 405     $name = substr( $name, 0, $max_id_length )
 406                         if ((length( $name ) > $max_id_length) && $critical);
 407     $scope->{ $name }++;
 408     return $name;
 409 }
 410
 411 # -------------------------------------------------------------------
 412 sub unreserve {
 413     my $name            = shift || '';
 414     my $schema_obj_name = shift || '';
 415     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 416
 417     # also trap fields that don't begin with a letter
 418     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 419
 420     if ( $schema_obj_name ) {
 421         ++$unreserve{"$schema_obj_name.$name"};
 422     }
 423     else {
 424         ++$unreserve{"$name (table name)"};
 425     }
 426
 427     my $unreserve = sprintf '%s_', $name;
 428     return $unreserve.$suffix;
 429 }
 430
 431 1;
 432
 433 # -------------------------------------------------------------------
 434
 435 =pod
 436
 437 =head1 SEE ALSO
 438
 439 SQL::Translator.
 440
 441 =head1 AUTHORS
 442
 443 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 444 Sybase producer, I just tweaked it for SQLServer. Thanks.
 445
 446 =cut