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