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 warnings;
  39 our ( $DEBUG, $WARN );
  40 our $VERSION = '1.59';
  41 $DEBUG = 1 unless defined $DEBUG;
  42
  43 use Data::Dumper;
  44 use SQL::Translator::Schema::Constants;
  45 use SQL::Translator::Utils qw(debug header_comment);
  46 use SQL::Translator::Generator::Utils;
  47 use SQL::Translator::Generator::DDL::SQLServer;
  48
  49 my $util = SQL::Translator::Generator::Utils->new( quote_chars => ['[', ']'] );
  50 my $future = SQL::Translator::Generator::DDL::SQLServer->new();
  51
  52 my %translate  = (
  53     date      => 'datetime',
  54     'time'    => 'datetime',
  55     # Sybase types
  56     #integer   => 'numeric',
  57     #int       => 'numeric',
  58     #number    => 'numeric',
  59     #money     => 'money',
  60     #varchar   => 'varchar',
  61     #varchar2  => 'varchar',
  62     #timestamp => 'datetime',
  63     #text      => 'varchar',
  64     #real      => 'double precision',
  65     #comment   => 'text',
  66     #bit       => 'bit',
  67     #tinyint   => 'smallint',
  68     #float     => 'double precision',
  69     #serial    => 'numeric',
  70     #boolean   => 'varchar',
  71     #char      => 'char',
  72     #long      => 'varchar',
  73 );
  74
  75 # If these datatypes have size appended the sql fails.
  76 my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/;
  77
  78 my $max_id_length    = 128;
  79 my %global_names;
  80
  81 =pod
  82
  83 =head1 SQLServer Create Table Syntax
  84
  85 TODO
  86
  87 =cut
  88
  89 sub produce {
  90     my $translator     = shift;
  91     $DEBUG             = $translator->debug;
  92     $WARN              = $translator->show_warnings;
  93     my $no_comments    = $translator->no_comments;
  94     my $add_drop_table = $translator->add_drop_table;
  95     my $schema         = $translator->schema;
  96
  97     %global_names = (); #reset
  98
  99     my $output;
 100     $output .= header_comment."\n" unless ($no_comments);
 101
 102     # Generate the DROP statements.
 103     if ($add_drop_table) {
 104         my @tables = sort { $b->order <=> $a->order } $schema->get_tables;
 105         $output .= "--\n-- Turn off constraints\n--\n\n" unless $no_comments;
 106         foreach my $table (@tables) {
 107             my $name = $table->name;
 108             my $q_name = unreserve($name);
 109             $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') ALTER TABLE $q_name NOCHECK CONSTRAINT all;\n"
 110         }
 111         $output .= "\n";
 112         $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments;
 113         foreach my $table (@tables) {
 114             my $name = $table->name;
 115             my $q_name = unreserve($name);
 116             $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $q_name;\n"
 117         }
 118     }
 119
 120     # Generate the CREATE sql
 121
 122     my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet
 123
 124     for my $table ( $schema->get_tables ) {
 125         my $table_name    = $table->name or next;
 126         my $table_name_ur = unreserve($table_name) || '';
 127
 128         my ( @comments, @field_defs, @index_defs, @constraint_defs );
 129
 130         push @comments, "\n\n--\n-- Table: $table_name_ur\n--"
 131         unless $no_comments;
 132
 133         push @comments, map { "-- $_" } $table->comments;
 134
 135         #
 136         # Fields
 137         #
 138         my %field_name_scope;
 139         for my $field ( $table->get_fields ) {
 140             my $field_name    = $field->name;
 141
 142             #
 143             # Datatype
 144             #
 145             my $data_type      = lc $field->data_type;
 146             my %extra          = $field->extra;
 147             my $list           = $extra{'list'} || [];
 148             # \todo deal with embedded quotes
 149             my $commalist      = join( ', ', map { qq['$_'] } @$list );
 150
 151             if ( $data_type eq 'enum' ) {
 152                 my $check_name = mk_name( $field_name . '_chk' );
 153                 push @constraint_defs,
 154                   "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 155                 $data_type .= 'character varying';
 156             }
 157
 158             push @field_defs, $future->field($field);
 159         }
 160
 161         #
 162         # Constraint Declarations
 163         #
 164         my @constraint_decs = ();
 165         for my $constraint ( $table->get_constraints ) {
 166             my $type    = $constraint->type || NORMAL;
 167             next unless $constraint->fields;
 168
 169             my $c_def;
 170             if ( $type eq FOREIGN_KEY ) {
 171                 push @foreign_constraints, $future->foreign_key_constraint($constraint);
 172                 next;
 173             }
 174
 175
 176             if ( $type eq PRIMARY_KEY ) {
 177                 $c_def = $future->primary_key_constraint($constraint)
 178             }
 179             elsif ( $type eq UNIQUE ) {
 180                 if (!grep { $_->is_nullable } $constraint->fields) {
 181                   $c_def = $future->unique_constraint_single($constraint)
 182                 } else {
 183                    push @index_defs, $future->unique_constraint_multiple($constraint);
 184                    next;
 185                 }
 186             }
 187             push @constraint_defs, $c_def;
 188         }
 189
 190         #
 191         # Indices
 192         #
 193         for my $index ( $table->get_indices ) {
 194             push @index_defs, $future->index($index)
 195         }
 196
 197         my $create_statement = "";
 198         $create_statement .= qq[CREATE TABLE $table_name_ur (\n].
 199             join( ",\n",
 200                 map { "  $_" } @field_defs, @constraint_defs
 201             ).
 202             "\n);"
 203         ;
 204
 205         $output .= join( "\n\n",
 206             @comments,
 207             $create_statement,
 208             @index_defs,
 209         );
 210     }
 211
 212 # Add FK constraints
 213     $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints;
 214
 215 # create view/procedure are NOT prepended to the input $sql, needs
 216 # to be filled in with the proper syntax
 217
 218 =pod
 219
 220     # Text of view is already a 'create view' statement so no need to
 221     # be fancy
 222     foreach ( $schema->get_views ) {
 223         my $name = $_->name();
 224         $output .= "\n\n";
 225         $output .= "--\n-- View: $name\n--\n\n" unless $no_comments;
 226         my $text = $_->sql();
 227         $text =~ s/\r//g;
 228         $output .= "$text\nGO\n";
 229     }
 230
 231     # Text of procedure already has the 'create procedure' stuff
 232     # so there is no need to do anything fancy. However, we should
 233     # think about doing fancy stuff with granting permissions and
 234     # so on.
 235     foreach ( $schema->get_procedures ) {
 236         my $name = $_->name();
 237         $output .= "\n\n";
 238         $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments;
 239         my $text = $_->sql();
 240       $text =~ s/\r//g;
 241         $output .= "$text\nGO\n";
 242     }
 243 =cut
 244
 245     return $output;
 246 }
 247
 248 sub mk_name {
 249     my ($name, $scope, $critical) = @_;
 250
 251     $scope ||= \%global_names;
 252     if ( my $prev = $scope->{ $name } ) {
 253         my $name_orig = $name;
 254         $name        .= sprintf( "%02d", ++$prev );
 255         substr($name, $max_id_length - 3) = "00"
 256             if length( $name ) > $max_id_length;
 257
 258         warn "The name '$name_orig' has been changed to ",
 259              "'$name' to make it unique.\n" if $WARN;
 260
 261         $scope->{ $name_orig }++;
 262     }
 263     $name = substr( $name, 0, $max_id_length )
 264                         if ((length( $name ) > $max_id_length) && $critical);
 265     $scope->{ $name }++;
 266     return unreserve($name);
 267 }
 268
 269 sub unreserve { $util->quote($_[0]) }
 270
 271 1;
 272
 273 =pod
 274
 275 =head1 SEE ALSO
 276
 277 SQL::Translator.
 278
 279 =head1 AUTHORS
 280
 281 Mark Addison E<lt>grommit@users.sourceforge.netE<gt> - Bulk of code from
 282 Sybase producer, I just tweaked it for SQLServer. Thanks.
 283
 284 =cut