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 qw/
   6     DBIx::Class::Schema::Loader::DBI
   7     DBIx::Class::Schema::Loader::DBI::Sybase::Common
   8 /;
   9 use Carp::Clan qw/^DBIx::Class/;
  10 use Class::C3;
  11
  12 our $VERSION = '0.04999_13';
  13
  14 =head1 NAME
  15
  16 DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.
  17
  18 =head1 SYNOPSIS
  19
  20   package My::Schema;
  21   use base qw/DBIx::Class::Schema::Loader/;
  22
  23   __PACKAGE__->loader_options( debug => 1 );
  24
  25   1;
  26
  27 =head1 DESCRIPTION
  28
  29 See L<DBIx::Class::Schema::Loader::Base>.
  30
  31 =cut
  32
  33 sub _setup {
  34     my $self = shift;
  35
  36     $self->next::method(@_);
  37     $self->{db_schema} ||= $self->_build_db_schema;
  38     $self->_set_quote_char_and_name_sep;
  39 }
  40
  41 # drop bad tables when constructing list
  42 sub _tables_list {
  43     my $self = shift;
  44
  45     my @tables = $self->next::method(@_);
  46     my @filtered_tables;
  47
  48     for my $table (@tables) {
  49         my $full_quoted_table;
  50         if($self->{db_schema}) {
  51             $full_quoted_table = $self->{db_schema} . $self->{_namesep} .
  52                 $self->_quote_table_name($table);
  53         } else {
  54             $full_quoted_table = $self->_quote_table_name($table);
  55         }
  56         my $dbh = $self->schema->storage->dbh;
  57         my $sth = $dbh->prepare($self->schema->storage->sql_maker
  58                 ->select(\$full_quoted_table, undef, \'1 = 0'));
  59         eval { $sth->execute };
  60         if (not $@) {
  61             push @filtered_tables, $table;
  62         }
  63         else {
  64             warn "Bad table or view '$table', ignoring.\n";
  65         }
  66     }
  67
  68     return @filtered_tables;
  69 }
  70
  71 # remove 'IDENTITY' from column data_type
  72 sub _columns_info_for {
  73     my $self   = shift;
  74     my $result = $self->next::method(@_);
  75
  76     for my $col (keys %$result) {
  77         $result->{$col}->{data_type} =~ s/\s* identity \s*//ix;
  78     }
  79
  80     return $result;
  81 }
  82
  83 sub _table_pk_info {
  84     my ($self, $table) = @_;
  85     my $dbh = $self->schema->storage->dbh;
  86     my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
  87     $sth->execute;
  88
  89     my @keydata;
  90
  91     while (my $row = $sth->fetchrow_hashref) {
  92         push @keydata, lc $row->{COLUMN_NAME};
  93     }
  94
  95     return \@keydata;
  96 }
  97
  98 sub _table_fk_info {
  99     my ($self, $table) = @_;
 100
 101     my ($local_cols, $remote_cols, $remote_table, @rels);
 102     my $dbh = $self->schema->storage->dbh;
 103     my $sth = $dbh->prepare(qq{sp_fkeys \@FKTABLE_NAME = '$table'});
 104     $sth->execute;
 105
 106     while (my $row = $sth->fetchrow_hashref) {
 107         my $fk = $row->{FK_NAME};
 108         push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME};
 109         push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME};
 110         $remote_table->{$fk} = $row->{PKTABLE_NAME};
 111     }
 112
 113     foreach my $fk (keys %$remote_table) {
 114         push @rels, {
 115                       local_columns => \@{$local_cols->{$fk}},
 116                       remote_columns => \@{$remote_cols->{$fk}},
 117                       remote_table => $remote_table->{$fk},
 118                     };
 119
 120     }
 121     return \@rels;
 122 }
 123
 124 sub _table_uniq_info {
 125     my ($self, $table) = @_;
 126
 127     my $dbh = $self->schema->storage->dbh;
 128     my $sth = $dbh->prepare(qq{SELECT CCU.CONSTRAINT_NAME, CCU.COLUMN_NAME FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE CCU
 129                                JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS TC ON (CCU.CONSTRAINT_NAME = TC.CONSTRAINT_NAME)
 130                                JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE KCU ON (CCU.CONSTRAINT_NAME = KCU.CONSTRAINT_NAME AND CCU.COLUMN_NAME = KCU.COLUMN_NAME)
 131                                WHERE CCU.TABLE_NAME = @{[ $dbh->quote($table) ]} AND CONSTRAINT_TYPE = 'UNIQUE' ORDER BY KCU.ORDINAL_POSITION});
 132     $sth->execute;
 133     my $constraints;
 134     while (my $row = $sth->fetchrow_hashref) {
 135         my $name = lc $row->{CONSTRAINT_NAME};
 136         my $col  = lc $row->{COLUMN_NAME};
 137         push @{$constraints->{$name}}, $col;
 138     }
 139
 140     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 141     return \@uniqs;
 142 }
 143
 144 sub _extra_column_info {
 145     my ($self, $info) = @_;
 146     my %extra_info;
 147
 148     my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
 149
 150     my $dbh = $self->schema->storage->dbh;
 151     my $sth = $dbh->prepare(qq{
 152         SELECT COLUMN_NAME
 153         FROM INFORMATION_SCHEMA.COLUMNS
 154         WHERE COLUMNPROPERTY(object_id(@{[ $dbh->quote($table) ]}, 'U'), '$column', 'IsIdentity') = 1
 155           AND TABLE_NAME = @{[ $dbh->quote($table) ]} AND COLUMN_NAME = @{[ $dbh->quote($column) ]}
 156     });
 157     $sth->execute();
 158
 159     if ($sth->fetchrow_array) {
 160         $extra_info{is_auto_increment} = 1;
 161     }
 162
 163 # get default
 164     $sth = $dbh->prepare(qq{
 165         SELECT COLUMN_DEFAULT
 166         FROM INFORMATION_SCHEMA.COLUMNS
 167         WHERE TABLE_NAME = @{[ $dbh->quote($table) ]} AND COLUMN_NAME = @{[ $dbh->quote($column) ]}
 168     });
 169     $sth->execute;
 170     my ($default) = $sth->fetchrow_array;
 171
 172     if (defined $default) {
 173         # strip parens
 174         $default =~ s/^\( (.*) \)\z/$1/x;
 175
 176         # Literal strings are in ''s, numbers are in ()s (in some versions of
 177         # MSSQL, in others they are unquoted) everything else is a function.
 178         $extra_info{default_value} =
 179             $default =~ /^['(] (.*) [)']\z/x ? $1 :
 180                 $default =~ /^\d/ ? $default : \$default;
 181     }
 182
 183     return \%extra_info;
 184 }
 185
 186 =head1 SEE ALSO
 187
 188 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 189 L<DBIx::Class::Schema::Loader::DBI>
 190
 191 =head1 AUTHOR
 192
 193 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 194
 195 =head1 LICENSE
 196
 197 This library is free software; you can redistribute it and/or modify it under
 198 the same terms as Perl itself.
 199
 200 =cut
 201
 202 1;