X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FProducer%2FSQLServer.pm;h=cb93c6480434ec97d96b85441135dffada7f0a35;hb=e6fcfabf1d69112e7ce8fcfe2fa6d798f1132823;hp=c1fd90d58e2c934a65316b9e7f133cd99fc5771c;hpb=1426be035ecff2a698f6bbbe26425858567ceebc;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Producer/SQLServer.pm b/lib/SQL/Translator/Producer/SQLServer.pm index c1fd90d..cb93c64 100644 --- a/lib/SQL/Translator/Producer/SQLServer.pm +++ b/lib/SQL/Translator/Producer/SQLServer.pm @@ -1,25 +1,5 @@ package SQL::Translator::Producer::SQLServer; -# ------------------------------------------------------------------- -# $Id: SQLServer.pm,v 1.3 2005-07-11 20:12:02 duality72 Exp $ -# ------------------------------------------------------------------- -# Copyright (C) 2002-4 SQLFairy Authors -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation; version 2. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -# 02111-1307 USA -# ------------------------------------------------------------------- - =head1 NAME SQL::Translator::Producer::SQLServer - MS SQLServer producer for SQL::Translator @@ -50,18 +30,24 @@ List of values for an enum field. * !! Write some tests !! * Reserved words list needs updating to SQLServer. - * Triggers, Procedures and Views havn't been tested at all. + * Triggers, Procedures and Views DO NOT WORK =cut use strict; -use vars qw[ $DEBUG $WARN $VERSION ]; -$VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/; +use warnings; +our ( $DEBUG, $WARN ); +our $VERSION = '1.59'; $DEBUG = 1 unless defined $DEBUG; use Data::Dumper; use SQL::Translator::Schema::Constants; use SQL::Translator::Utils qw(debug header_comment); +use SQL::Translator::Generator::Utils; +use SQL::Translator::Generator::DDL::SQLServer; + +my $util = SQL::Translator::Generator::Utils->new( quote_chars => ['[', ']'] ); +my $future = SQL::Translator::Generator::DDL::SQLServer->new(); my %translate = ( date => 'datetime', @@ -80,39 +66,17 @@ my %translate = ( #bit => 'bit', #tinyint => 'smallint', #float => 'double precision', - #serial => 'numeric', + #serial => 'numeric', #boolean => 'varchar', #char => 'char', #long => 'varchar', ); -# TODO - This is still the Sybase list! -my %reserved = map { $_, 1 } qw[ - ALL ANALYSE ANALYZE AND ANY AS ASC - BETWEEN BINARY BOTH - CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS - CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER - DEFAULT DEFERRABLE DESC DISTINCT DO - ELSE END EXCEPT - FALSE FOR FOREIGN FREEZE FROM FULL - GROUP HAVING - ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL - JOIN LEADING LEFT LIKE LIMIT - NATURAL NEW NOT NOTNULL NULL - OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS - PRIMARY PUBLIC REFERENCES RIGHT - SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE - UNION UNIQUE USER USING VERBOSE WHEN WHERE -]; - # If these datatypes have size appended the sql fails. my @no_size = qw/tinyint smallint int integer bigint text bit image datetime/; my $max_id_length = 128; -my %used_identifiers = (); my %global_names; -my %unreserve; -my %truncated; =pod @@ -122,7 +86,6 @@ TODO =cut -# ------------------------------------------------------------------- sub produce { my $translator = shift; $DEBUG = $translator->debug; @@ -131,31 +94,35 @@ sub produce { my $add_drop_table = $translator->add_drop_table; my $schema = $translator->schema; + %global_names = (); #reset + my $output; $output .= header_comment."\n" unless ($no_comments); - # Generate the DROP statements. We do this in one block here as if we - # have fkeys we need to drop in the correct order otherwise they will fail - # due to the dependancies the fkeys setup. (There is no way to turn off - # fkey checking while we sort the schema like MySQL's set - # foreign_key_checks=0) - # We assume the tables are in the correct order to set them up as you need - # to have created a table to fkey to it. So the reverse order should drop - # them properly, fingers crossed... + # Generate the DROP statements. if ($add_drop_table) { + my @tables = sort { $b->order <=> $a->order } $schema->get_tables; + $output .= "--\n-- Turn off constraints\n--\n\n" unless $no_comments; + foreach my $table (@tables) { + my $name = $table->name; + my $q_name = unreserve($name); + $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') ALTER TABLE $q_name NOCHECK CONSTRAINT all;\n" + } + $output .= "\n"; $output .= "--\n-- Drop tables\n--\n\n" unless $no_comments; - foreach my $table ( - sort { $b->order <=> $a->order } $schema->get_tables - ) { - my $name = unreserve($table->name); - $output .= qq{IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $name;\n\n} + foreach my $table (@tables) { + my $name = $table->name; + my $q_name = unreserve($name); + $output .= "IF EXISTS (SELECT name FROM sysobjects WHERE name = '$name' AND type = 'U') DROP TABLE $q_name;\n" } } # Generate the CREATE sql + + my @foreign_constraints = (); # these need to be added separately, as tables may not exist yet + for my $table ( $schema->get_tables ) { my $table_name = $table->name or next; - $table_name = mk_name( $table_name, '', undef, 1 ); my $table_name_ur = unreserve($table_name) || ''; my ( @comments, @field_defs, @index_defs, @constraint_defs ); @@ -170,156 +137,106 @@ sub produce { # my %field_name_scope; for my $field ( $table->get_fields ) { - my $field_name = mk_name( - $field->name, '', \%field_name_scope, undef,1 - ); - my $field_name_ur = unreserve( $field_name, $table_name ); - my $field_def = qq["$field_name_ur"]; - $field_def =~ s/\"//g; - if ( $field_def =~ /identity/ ){ - $field_def =~ s/identity/pidentity/; - } + my $field_name = $field->name; # # Datatype # my $data_type = lc $field->data_type; - my $orig_data_type = $data_type; my %extra = $field->extra; my $list = $extra{'list'} || []; # \todo deal with embedded quotes my $commalist = join( ', ', map { qq['$_'] } @$list ); - my $seq_name; if ( $data_type eq 'enum' ) { - my $check_name = mk_name( - $table_name.'_'.$field_name, 'chk' ,undef, 1 - ); + my $check_name = mk_name( $field_name . '_chk' ); push @constraint_defs, - "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))"; + "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))"; $data_type .= 'character varying'; } - elsif ( $data_type eq 'set' ) { - $data_type .= 'character varying'; - } - else { - if ( defined $translate{ $data_type } ) { - $data_type = $translate{ $data_type }; - } - else { - warn "Unknown datatype: $data_type ", - "($table_name.$field_name)\n" if $WARN; - } - } - - my $size = $field->size; - if ( grep $_ eq $data_type, @no_size) { - # SQLServer doesn't seem to like sizes on some datatypes - $size = undef; - } - elsif ( !$size ) { - if ( $data_type =~ /numeric/ ) { - $size = '9,0'; - } - elsif ( $orig_data_type eq 'text' ) { - #interpret text fields as long varchars - $size = '255'; - } - elsif ( - $data_type eq 'varchar' && - $orig_data_type eq 'boolean' - ) { - $size = '6'; - } - elsif ( $data_type eq 'varchar' ) { - $size = '255'; - } - } - - $field_def .= " $data_type"; - $field_def .= "($size)" if $size; - - $field_def .= ' IDENTITY' if $field->is_auto_increment; - - # - # Not null constraint - # - unless ( $field->is_nullable ) { - $field_def .= ' NOT NULL'; - } - else { - $field_def .= ' NULL' if $data_type ne 'bit'; - } - push @field_defs, $field_def; - # - # Default value - # - my $default = $field->default_value; - if ( defined $default ) { - $field_def .= sprintf( ' DEFAULT %s', - ( $field->is_auto_increment && $seq_name ) - ? qq[nextval('"$seq_name"'::text)] : - ( $default =~ m/null/i ) ? 'NULL' : "'$default'" - ); - } + push @field_defs, $future->field($field); } # # Constraint Declarations # my @constraint_decs = (); - my $c_name_default; for my $constraint ( $table->get_constraints ) { my $name = $constraint->name || ''; + my $name_ur = unreserve($name); # Make sure we get a unique name - $name = mk_name( $name, undef, undef, 1 ) if $name; my $type = $constraint->type || NORMAL; - my @fields = map { unreserve( $_, $table_name ) } + my @fields = map { unreserve( $_ ) } $constraint->fields; - my @rfields = map { unreserve( $_, $table_name ) } + my @rfields = map { unreserve( $_ ) } $constraint->reference_fields; next unless @fields; - if ( $type eq PRIMARY_KEY ) { - $name ||= mk_name( $table_name, 'pk', undef,1 ); - push @constraint_defs, - "CONSTRAINT $name PRIMARY KEY ". - '(' . join( ', ', @fields ) . ')'; - } - elsif ( $type eq FOREIGN_KEY ) { - $name ||= mk_name( $table_name, 'fk', undef,1 ); - #$name = mk_name( ($name || $table_name), 'fk', undef,1 ); - push @constraint_defs, - "CONSTRAINT $name FOREIGN KEY". + my $c_def; + if ( $type eq FOREIGN_KEY ) { + $name ||= mk_name( $table_name . '_fk' ); + my $on_delete = uc ($constraint->on_delete || ''); + my $on_update = uc ($constraint->on_update || ''); + + # The default implicit constraint action in MSSQL is RESTRICT + # but you can not specify it explicitly. Go figure :) + for ($on_delete, $on_update) { + undef $_ if $_ eq 'RESTRICT' + } + + $c_def = + "ALTER TABLE $table_name_ur ADD CONSTRAINT $name_ur FOREIGN KEY". ' (' . join( ', ', @fields ) . ') REFERENCES '. - $constraint->reference_table. - ' (' . join( ', ', @rfields ) . ')'; + unreserve($constraint->reference_table). + ' (' . join( ', ', @rfields ) . ')' + ; + + if ( $on_delete && $on_delete ne "NO ACTION") { + $c_def .= " ON DELETE $on_delete"; + } + if ( $on_update && $on_update ne "NO ACTION") { + $c_def .= " ON UPDATE $on_update"; + } + + $c_def .= ";"; + + push @foreign_constraints, $c_def; + next; + } + + + if ( $type eq PRIMARY_KEY ) { + $c_def = $future->primary_key_constraint($constraint) } elsif ( $type eq UNIQUE ) { - $name ||= mk_name( - $table_name, - $name || ++$c_name_default,undef, 1 - ); - push @constraint_defs, - "CONSTRAINT $name UNIQUE " . - '(' . join( ', ', @fields ) . ')'; + $name = $name_ur || mk_name( $table_name . '_uc' ); + my @nullable = grep { $_->is_nullable } $constraint->fields; + if (!@nullable) { + $c_def = + "CONSTRAINT $name UNIQUE " . + '(' . join( ', ', @fields ) . ')'; + } else { + push @index_defs, + "CREATE UNIQUE NONCLUSTERED INDEX $name_ur ON $table_name_ur (" . + join( ', ', @fields ) . ')' . + ' WHERE ' . join( ' AND ', map unreserve($_->name) . ' IS NOT NULL', @nullable ) . ';'; + next; + } } + push @constraint_defs, $c_def; } # # Indices # for my $index ( $table->get_indices ) { - my $idx_name = $index->name || mk_name($table_name,'idx',undef,1); - push @index_defs, - "CREATE INDEX $idx_name ON $table_name (". - join( ', ', $index->fields ) . ");"; + push @index_defs, $future->index($index) } my $create_statement = ""; $create_statement .= qq[CREATE TABLE $table_name_ur (\n]. - join( ",\n", + join( ",\n", map { " $_" } @field_defs, @constraint_defs ). "\n);" @@ -329,19 +246,26 @@ sub produce { @comments, $create_statement, @index_defs, - '' ); } +# Add FK constraints + $output .= join ("\n", '', @foreign_constraints) if @foreign_constraints; + +# create view/procedure are NOT prepended to the input $sql, needs +# to be filled in with the proper syntax + +=pod + # Text of view is already a 'create view' statement so no need to # be fancy foreach ( $schema->get_views ) { my $name = $_->name(); $output .= "\n\n"; - $output .= "--\n-- View: $name\n--" unless $no_comments; + $output .= "--\n-- View: $name\n--\n\n" unless $no_comments; my $text = $_->sql(); - $text =~ s/\r//g; - $output .= $text; + $text =~ s/\r//g; + $output .= "$text\nGO\n"; } # Text of procedure already has the 'create procedure' stuff @@ -351,54 +275,24 @@ sub produce { foreach ( $schema->get_procedures ) { my $name = $_->name(); $output .= "\n\n"; - $output .= "--\n-- Procedure: $name\n--" unless $no_comments; + $output .= "--\n-- Procedure: $name\n--\n\n" unless $no_comments; my $text = $_->sql(); - $text =~ s/\r//g; - $output .= $text; - } - - # Warn out how we messed with the names. - if ( $WARN ) { - if ( %truncated ) { - warn "Truncated " . keys( %truncated ) . " names:\n"; - warn "\t" . join( "\n\t", sort keys %truncated ) . "\n"; - } - if ( %unreserve ) { - warn "Encounted " . keys( %unreserve ) . - " unsafe names in schema (reserved or invalid):\n"; - warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n"; - } + $text =~ s/\r//g; + $output .= "$text\nGO\n"; } +=cut return $output; } -# ------------------------------------------------------------------- sub mk_name { - my $basename = shift || ''; - my $type = shift || ''; - my $scope = shift || ''; - my $critical = shift || ''; - my $basename_orig = $basename; - my $max_name = $type - ? $max_id_length - (length($type) + 1) - : $max_id_length; - $basename = substr( $basename, 0, $max_name ) - if length( $basename ) > $max_name; - my $name = $type ? "${type}_$basename" : $basename; - - if ( $basename ne $basename_orig and $critical ) { - my $show_type = $type ? "+'$type'" : ""; - warn "Truncating '$basename_orig'$show_type to $max_id_length ", - "character limit to make '$name'\n" if $WARN; - $truncated{ $basename_orig } = $name; - } + my ($name, $scope, $critical) = @_; $scope ||= \%global_names; if ( my $prev = $scope->{ $name } ) { my $name_orig = $name; $name .= sprintf( "%02d", ++$prev ); - substr($name, $max_id_length - 3) = "00" + substr($name, $max_id_length - 3) = "00" if length( $name ) > $max_id_length; warn "The name '$name_orig' has been changed to ", @@ -406,36 +300,16 @@ sub mk_name { $scope->{ $name_orig }++; } - $name = substr( $name, 0, $max_id_length ) + $name = substr( $name, 0, $max_id_length ) if ((length( $name ) > $max_id_length) && $critical); $scope->{ $name }++; - return $name; + return unreserve($name); } -# ------------------------------------------------------------------- -sub unreserve { - my $name = shift || ''; - my $schema_obj_name = shift || ''; - my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : ''; - - # also trap fields that don't begin with a letter - return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i; - - if ( $schema_obj_name ) { - ++$unreserve{"$schema_obj_name.$name"}; - } - else { - ++$unreserve{"$name (table name)"}; - } - - my $unreserve = sprintf '%s_', $name; - return $unreserve.$suffix; -} +sub unreserve { $util->quote($_[0]) } 1; -# ------------------------------------------------------------------- - =pod =head1 SEE ALSO