X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FMSSQL.pm;h=17e8dd91acf807d936c2eed980a984d14005b719;hb=f671b6308c4f2210255b2eaa12fc47a49621d436;hp=fef1f2ee7cf16624514a673e92a8f39c1a2197f8;hpb=6ed0a90ca50ebfff74e95066acec78a7c7714d55;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm index fef1f2e..17e8dd9 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm @@ -2,52 +2,103 @@ package DBIx::Class::Schema::Loader::DBI::MSSQL; use strict; use warnings; -use base 'DBIx::Class::Schema::Loader::DBI'; +use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; use Carp::Clan qw/^DBIx::Class/; -use Class::C3; +use mro 'c3'; -our $VERSION = '0.04999_06'; +our $VERSION = '0.07002'; =head1 NAME DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation. -=head1 SYNOPSIS +=head1 DESCRIPTION - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; +Base driver for Microsoft SQL Server, used by +L for support +via L and +L for support via +L. - __PACKAGE__->loader_options( debug => 1 ); +See L and L for +usage information. - 1; +=head1 CASE SENSITIVITY -=head1 DESCRIPTION +Most MSSQL databases use C (case-insensitive) collation, for this reason +generated column names are lower-cased as this makes them easier to work with +in L. -See L. +We attempt to detect the database collation at startup, and set the column +lowercasing behavior accordingly, as lower-cased column names do not work on +case-sensitive databases. -=cut +To manually control case-sensitive mode, put: -sub _rebless { - my $self = shift; + preserve_case => 1|0 - $self->schema->storage->sql_maker->quote_char([qw/[ ]/]) - unless $self->schema->storage->sql_maker->quote_char; +in your Loader options. - $self->schema->storage->sql_maker->name_sep('.') - unless $self->schema->storage->sql_maker->name_sep; -} +See L. + +B this option used to be called C, but has +been renamed to a more generic option. + +=cut sub _setup { my $self = shift; $self->next::method(@_); - $self->{db_schema} ||= 'dbo'; + + return if defined $self->preserve_case; + + my $dbh = $self->schema->storage->dbh; + + # We use the sys.databases query for the general case, and fallback to + # databasepropertyex() if for some reason sys.databases is not available, + # which does not work over DBD::ODBC with unixODBC+FreeTDS. + # + # XXX why does databasepropertyex() not work over DBD::ODBC ? + # + # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx + my ($collation_name) = + eval { $dbh->selectrow_array('SELECT collation_name FROM sys.databases WHERE name = DB_NAME()') } + || eval { $dbh->selectrow_array("SELECT CAST(databasepropertyex(DB_NAME(), 'Collation') AS VARCHAR)") }; + + if (not $collation_name) { + warn <<'EOF'; + +WARNING: MSSQL Collation detection failed. Defaulting to case-insensitive mode. +Override the 'preserve_case' attribute in your Loader options if needed. + +See 'preserve_case' in +perldoc DBIx::Class::Schema::Loader::Base +EOF + $self->preserve_case(0); + return; + } + + my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/; + + $self->preserve_case($case_sensitive ? 1 : 0); } -# DBD::Sybase doesn't implement get_info properly -#sub _build_quoter { [qw/[ ]/] } -sub _build_quoter { '"' } -sub _build_namesep { '.' } +sub _tables_list { + my ($self, $opts) = @_; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare(<<'EOF'); +SELECT t.table_name +FROM INFORMATION_SCHEMA.TABLES t +WHERE t.table_schema = ? +EOF + $sth->execute($self->db_schema); + + my @tables = map @$_, @{ $sth->fetchall_arrayref }; + + return $self->_filter_tables(\@tables, $opts); +} sub _table_pk_info { my ($self, $table) = @_; @@ -58,7 +109,7 @@ sub _table_pk_info { my @keydata; while (my $row = $sth->fetchrow_hashref) { - push @keydata, lc $row->{COLUMN_NAME}; + push @keydata, $self->_lc($row->{COLUMN_NAME}); } return \@keydata; @@ -67,15 +118,17 @@ sub _table_pk_info { sub _table_fk_info { my ($self, $table) = @_; - my ($local_cols, $remote_cols, $remote_table, @rels); + my ($local_cols, $remote_cols, $remote_table, @rels, $sth); my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{sp_fkeys \@FKTABLE_NAME = '$table'}); - $sth->execute; + eval { + $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'}); + $sth->execute; + }; - while (my $row = $sth->fetchrow_hashref) { + while (my $row = eval { $sth->fetchrow_hashref }) { my $fk = $row->{FK_NAME}; - push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME}; - push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME}; + push @{$local_cols->{$fk}}, $self->_lc($row->{FKCOLUMN_NAME}); + push @{$remote_cols->{$fk}}, $self->_lc($row->{PKCOLUMN_NAME}); $remote_table->{$fk} = $row->{PKTABLE_NAME}; } @@ -94,15 +147,20 @@ sub _table_uniq_info { my ($self, $table) = @_; my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{SELECT CCU.CONSTRAINT_NAME, CCU.COLUMN_NAME FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE CCU - JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS TC ON (CCU.CONSTRAINT_NAME = TC.CONSTRAINT_NAME) - JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE KCU ON (CCU.CONSTRAINT_NAME = KCU.CONSTRAINT_NAME AND CCU.COLUMN_NAME = KCU.COLUMN_NAME) - WHERE CCU.TABLE_NAME = '$table' AND CONSTRAINT_TYPE = 'UNIQUE' ORDER BY KCU.ORDINAL_POSITION}); + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare(qq{ +SELECT ccu.constraint_name, ccu.column_name +FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE ccu +JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc on (ccu.constraint_name = tc.constraint_name) +JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name) +wHERE ccu.table_name = @{[ $dbh->quote($table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position + }); $sth->execute; my $constraints; while (my $row = $sth->fetchrow_hashref) { - my $name = lc $row->{CONSTRAINT_NAME}; - my $col = lc $row->{COLUMN_NAME}; + my $name = $row->{constraint_name}; + my $col = $self->_lc($row->{column_name}); push @{$constraints->{$name}}, $col; } @@ -110,36 +168,143 @@ sub _table_uniq_info { return \@uniqs; } -sub _extra_column_info { - my ($self, $info) = @_; - my %extra_info; - - my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/}; - - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{SELECT COLUMN_NAME - FROM INFORMATION_SCHEMA.COLUMNS - WHERE COLUMNPROPERTY(object_id('$table', 'U'), '$column', 'IsIdentity') = 1 AND TABLE_NAME = '$table' AND COLUMN_NAME = '$column' - }); - $sth->execute(); - - if ($sth->fetchrow_array) { - $extra_info{is_auto_increment} = 1; +sub _columns_info_for { + my $self = shift; + my ($table) = @_; + + my $result = $self->next::method(@_); + + while (my ($col, $info) = each %$result) { + my $dbh = $self->schema->storage->dbh; + +# find identities + my $sth = $dbh->prepare(qq{ +SELECT column_name +FROM INFORMATION_SCHEMA.COLUMNS +WHERE columnproperty(object_id(@{[ $dbh->quote($table) ]}, 'U'), @{[ $dbh->quote($col) ]}, 'IsIdentity') = 1 +AND table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]} + }); + if (eval { $sth->execute; $sth->fetchrow_array }) { + $info->{is_auto_increment} = 1; + $info->{data_type} =~ s/\s*identity//i; + delete $info->{size}; + } + +# fix types + if ($info->{data_type} eq 'int') { + $info->{data_type} = 'integer'; + } + elsif ($info->{data_type} eq 'timestamp') { + $info->{inflate_datetime} = 0; + } + elsif ($info->{data_type} =~ /^(?:numeric|decimal)\z/) { + if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) { + delete $info->{size}; + } + } + elsif ($info->{data_type} eq 'float') { + $info->{data_type} = 'double precision'; + } + elsif ($info->{data_type} =~ /^(?:small)?datetime\z/) { + # fixup for DBD::Sybase + if ($info->{default_value} && $info->{default_value} eq '3') { + delete $info->{default_value}; + } + } + elsif ($info->{data_type} eq 'datetimeoffset') { + $info->{size} = { + 26 => 0, + 28 => 1, + 29 => 2, + 30 => 3, + 31 => 4, + 32 => 5, + 33 => 6, + 34 => 7, + }->{$info->{size}}; + + delete $info->{size} if $info->{size} == 7; + } + elsif ($info->{data_type} eq 'datetime2') { + $info->{size} = { + 19 => 0, + 21 => 1, + 22 => 2, + 23 => 3, + 24 => 4, + 25 => 5, + 26 => 6, + 27 => 7, + }->{$info->{size}}; + + delete $info->{size} if $info->{size} == 7; + } + elsif ($info->{data_type} eq 'time') { + $info->{size} = { + 8 => 0, + 10 => 1, + 11 => 2, + 12 => 3, + 13 => 4, + 14 => 5, + 15 => 6, + 16 => 7, + }->{$info->{size}}; + + delete $info->{size} if $info->{size} == 7; + } + + if ($info->{data_type} !~ /^(?:n?char|n?varchar|binary|varbinary|numeric|decimal|float|datetime(?:2|offset)|time)\z/) { + delete $info->{size}; + } + +# get default + $sth = $dbh->prepare(qq{ +SELECT column_default +FROM INFORMATION_SCHEMA.COLUMNS +wHERE table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]} + }); + my ($default) = eval { $sth->execute; $sth->fetchrow_array }; + + if (defined $default) { + # strip parens + $default =~ s/^\( (.*) \)\z/$1/x; + + # Literal strings are in ''s, numbers are in ()s (in some versions of + # MSSQL, in others they are unquoted) everything else is a function. + $info->{default_value} = + $default =~ /^['(] (.*) [)']\z/x ? $1 : + $default =~ /^\d/ ? $default : \$default; + + if ((eval { lc ${ $info->{default_value} } }||'') eq 'getdate()') { + ${ $info->{default_value} } = 'current_timestamp'; + + my $getdate = 'getdate()'; + $info->{original}{default_value} = \$getdate; + } + } } - return \%extra_info; + return $result; } - =head1 SEE ALSO +L, +L, L, L, L =head1 AUTHOR -Justin Hunter C +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. =cut 1; +# vim:et sts=4 sw=4 tw=0: