X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FMSSQL.pm;h=71d49d42342ebb80f2dd50584f899bf2a3728553;hb=2a8e93e98aace9a187a57a66a8d71fabc6a48a8c;hp=cf8fc0ad3ab87c39296a38f2f4b490f00904af3f;hpb=5c6fb0a1f3596f82f6335a0fdf57f6af0397e58e;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 cf8fc0a..71d49d4 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm @@ -2,52 +2,77 @@ package DBIx::Class::Schema::Loader::DBI::MSSQL; use strict; use warnings; -use base qw/ - DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader::DBI::Sybase::Common -/; +use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; use Carp::Clan qw/^DBIx::Class/; use Class::C3; -our $VERSION = '0.04999_10'; +__PACKAGE__->mk_group_accessors('simple', qw/ + case_sensitive_collation +/); + +our $VERSION = '0.06000'; =head1 NAME DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation. -=head1 SYNOPSIS - - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; +=head1 DESCRIPTION - __PACKAGE__->loader_options( debug => 1 ); +Base driver for Microsoft SQL Server, used by +L for support +via L and +L for support via +L. - 1; +See L and L for +usage information. -=head1 DESCRIPTION +=cut -See L. +sub _is_case_sensitive { + my $self = shift; -=cut + return $self->case_sensitive_collation ? 1 : 0; +} sub _setup { my $self = shift; - $self->next::method(@_); - $self->{db_schema} ||= $self->_build_db_schema; - $self->_set_quote_char_and_name_sep; + $self->next::method; + + my $dbh = $self->schema->storage->dbh; + + my ($collation_name) = $dbh->selectrow_array(<<'EOS'); +SELECT collation_name +FROM sys.databases +WHERE name = DB_NAME() +EOS + + my ($sensitivity) = $collation_name =~ /(C\w)_[A-z]+\z/; + + $self->case_sensitive_collation($sensitivity eq 'CS' ? 1 : 0); } -# remove 'IDENTITY' from column data_type -sub _columns_info_for { - my $self = shift; - my $result = $self->next::method(@_); +sub _lc { + my ($self, $name) = @_; - for my $col (keys %$result) { - $result->{$col}->{data_type} =~ s/\s* identity \s*//ix; - } + return $self->case_sensitive_collation ? $name : lc($name); +} - return $result; +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 lower(t.table_schema) = ? +EOF + $sth->execute(lc $self->db_schema); + + my @tables = map @$_, @{ $sth->fetchall_arrayref }; + + return $self->_filter_tables(\@tables, $opts); } sub _table_pk_info { @@ -59,7 +84,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; @@ -68,15 +93,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}; } @@ -95,15 +122,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 lower(ccu.table_name) = @{[ $dbh->quote(lc $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; } @@ -111,57 +143,67 @@ sub _table_uniq_info { return \@uniqs; } -sub _extra_column_info { - my ($self, $info) = @_; - my %extra_info; +sub _columns_info_for { + my $self = shift; + my ($table) = @_; - my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/}; + my $result = $self->next::method(@_); - 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; - } + while (my ($col, $info) = each %$result) { + my $dbh = $self->schema->storage->dbh; + + my $sth = $dbh->prepare(qq{ +SELECT column_name +FROM information_schema.columns +WHERE columnproperty(object_id(@{[ $dbh->quote(lc $table) ]}, 'U'), @{[ $dbh->quote(lc $col) ]}, 'IsIdentity') = 1 +AND lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]} + }); + if (eval { $sth->execute; $sth->fetchrow_array }) { + $info->{is_auto_increment} = 1; + $info->{data_type} =~ s/\s*identity//i; + delete $info->{size}; + } # get default - $sth = $dbh->prepare(qq{ - SELECT COLUMN_DEFAULT - FROM INFORMATION_SCHEMA.COLUMNS - WHERE TABLE_NAME = '$table' AND COLUMN_NAME = '$column' - }); - $sth->execute; - my ($default) = $sth->fetchrow_array; - - if (defined $default) { - # strip parens - $default =~ s/^\( (.*) \)\z/$1/x; - - # literal or function? - $extra_info{default_value} = - $default =~ /^' (.*) '\z/x ? $1 : \$default; + $sth = $dbh->prepare(qq{ +SELECT column_default +FROM information_schema.columns +wHERE lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $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; + } } - return \%extra_info; + return $result; } =head1 SEE ALSO +L, +L, L, L, L =head1 AUTHOR -Justin Hunter C +See L and L. -=head1 CONTRIBUTORS +=head1 LICENSE -Rafael Kitover +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: