lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm

   1 package DBIx::Class::Schema::Loader::DBI::MSSQL;
   2
   3 use strict;
   4 use warnings;
   5 use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
   6 use Carp::Clan qw/^DBIx::Class/;
   7 use Class::C3;
   8
   9 __PACKAGE__->mk_group_accessors('simple', qw/
  10     case_sensitive_collation
  11 /);
  12
  13 our $VERSION = '0.06000';
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.
  18
  19 =head1 DESCRIPTION
  20
  21 Base driver for Microsoft SQL Server, used by
  22 L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> for support
  23 via L<DBD::Sybase> and
  24 L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server> for support via
  25 L<DBD::ODBC>.
  26
  27 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base> for
  28 usage information.
  29
  30 =cut
  31
  32 sub _is_case_sensitive {
  33     my $self = shift;
  34
  35     return $self->case_sensitive_collation ? 1 : 0;
  36 }
  37
  38 sub _setup {
  39     my $self = shift;
  40
  41     $self->next::method;
  42
  43     my $dbh = $self->schema->storage->dbh;
  44
  45     my ($collation_name) = $dbh->selectrow_array(<<'EOS');
  46 SELECT collation_name
  47 FROM sys.databases
  48 WHERE name = DB_NAME()
  49 EOS
  50
  51     my ($sensitivity) = $collation_name =~ /(C\w)_[A-z]+\z/;
  52
  53     $self->case_sensitive_collation($sensitivity eq 'CS' ? 1 : 0);
  54 }
  55
  56 sub _lc {
  57     my ($self, $name) = @_;
  58
  59     return $self->case_sensitive_collation ? $name : lc($name);
  60 }
  61
  62 sub _tables_list {
  63     my ($self, $opts) = @_;
  64
  65     my $dbh = $self->schema->storage->dbh;
  66     my $sth = $dbh->prepare(<<'EOF');
  67 SELECT t.table_name
  68 FROM information_schema.tables t
  69 WHERE lower(t.table_schema) = ?
  70 EOF
  71     $sth->execute(lc $self->db_schema);
  72
  73     my @tables = map @$_, @{ $sth->fetchall_arrayref };
  74
  75     return $self->_filter_tables(\@tables, $opts);
  76 }
  77
  78 sub _table_pk_info {
  79     my ($self, $table) = @_;
  80     my $dbh = $self->schema->storage->dbh;
  81     my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
  82     $sth->execute;
  83
  84     my @keydata;
  85
  86     while (my $row = $sth->fetchrow_hashref) {
  87         push @keydata, $self->_lc($row->{COLUMN_NAME});
  88     }
  89
  90     return \@keydata;
  91 }
  92
  93 sub _table_fk_info {
  94     my ($self, $table) = @_;
  95
  96     my ($local_cols, $remote_cols, $remote_table, @rels, $sth);
  97     my $dbh = $self->schema->storage->dbh;
  98     eval {
  99         $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
 100         $sth->execute;
 101     };
 102
 103     while (my $row = eval { $sth->fetchrow_hashref }) {
 104         my $fk = $row->{FK_NAME};
 105         push @{$local_cols->{$fk}}, $self->_lc($row->{FKCOLUMN_NAME});
 106         push @{$remote_cols->{$fk}}, $self->_lc($row->{PKCOLUMN_NAME});
 107         $remote_table->{$fk} = $row->{PKTABLE_NAME};
 108     }
 109
 110     foreach my $fk (keys %$remote_table) {
 111         push @rels, {
 112                       local_columns => \@{$local_cols->{$fk}},
 113                       remote_columns => \@{$remote_cols->{$fk}},
 114                       remote_table => $remote_table->{$fk},
 115                     };
 116
 117     }
 118     return \@rels;
 119 }
 120
 121 sub _table_uniq_info {
 122     my ($self, $table) = @_;
 123
 124     my $dbh = $self->schema->storage->dbh;
 125     local $dbh->{FetchHashKeyName} = 'NAME_lc';
 126
 127     my $sth = $dbh->prepare(qq{
 128 SELECT ccu.constraint_name, ccu.column_name
 129 FROM information_schema.constraint_column_usage ccu
 130 JOIN information_schema.table_constraints tc on (ccu.constraint_name = tc.constraint_name)
 131 JOIN information_schema.key_column_usage kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name)
 132 wHERE lower(ccu.table_name) = @{[ $dbh->quote(lc $table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position
 133     });
 134     $sth->execute;
 135     my $constraints;
 136     while (my $row = $sth->fetchrow_hashref) {
 137         my $name = $row->{constraint_name};
 138         my $col  = $self->_lc($row->{column_name});
 139         push @{$constraints->{$name}}, $col;
 140     }
 141
 142     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 143     return \@uniqs;
 144 }
 145
 146 sub _columns_info_for {
 147     my $self    = shift;
 148     my ($table) = @_;
 149
 150     my $result = $self->next::method(@_);
 151
 152     while (my ($col, $info) = each %$result) {
 153         my $dbh = $self->schema->storage->dbh;
 154
 155         my $sth = $dbh->prepare(qq{
 156 SELECT column_name
 157 FROM information_schema.columns
 158 WHERE columnproperty(object_id(@{[ $dbh->quote(lc $table) ]}, 'U'), @{[ $dbh->quote(lc $col) ]}, 'IsIdentity') = 1
 159 AND lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
 160         });
 161         if (eval { $sth->execute; $sth->fetchrow_array }) {
 162             $info->{is_auto_increment} = 1;
 163             $info->{data_type} =~ s/\s*identity//i;
 164             delete $info->{size};
 165         }
 166
 167 # get default
 168         $sth = $dbh->prepare(qq{
 169 SELECT column_default
 170 FROM information_schema.columns
 171 wHERE lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
 172         });
 173         my ($default) = eval { $sth->execute; $sth->fetchrow_array };
 174
 175         if (defined $default) {
 176             # strip parens
 177             $default =~ s/^\( (.*) \)\z/$1/x;
 178
 179             # Literal strings are in ''s, numbers are in ()s (in some versions of
 180             # MSSQL, in others they are unquoted) everything else is a function.
 181             $info->{default_value} =
 182                 $default =~ /^['(] (.*) [)']\z/x ? $1 :
 183                     $default =~ /^\d/ ? $default : \$default;
 184         }
 185     }
 186
 187     return $result;
 188 }
 189
 190 =head1 SEE ALSO
 191
 192 L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>,
 193 L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
 194 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 195 L<DBIx::Class::Schema::Loader::DBI>
 196
 197 =head1 AUTHOR
 198
 199 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 200
 201 =head1 LICENSE
 202
 203 This library is free software; you can redistribute it and/or modify it under
 204 the same terms as Perl itself.
 205
 206 =cut
 207
 208 1;
 209 # vim:et sts=4 sw=4 tw=0: