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 mro 'c3';
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use Try::Tiny;
   9 use namespace::clean;
  10
  11 our $VERSION = '0.07010';
  12
  13 =head1 NAME
  14
  15 DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.
  16
  17 =head1 DESCRIPTION
  18
  19 Base driver for Microsoft SQL Server, used by
  20 L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> for support
  21 via L<DBD::Sybase> and
  22 L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server> for support via
  23 L<DBD::ODBC>.
  24
  25 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base> for
  26 usage information.
  27
  28 =head1 CASE SENSITIVITY
  29
  30 Most MSSQL databases use C<CI> (case-insensitive) collation, for this reason
  31 generated column names are lower-cased as this makes them easier to work with
  32 in L<DBIx::Class>.
  33
  34 We attempt to detect the database collation at startup, and set the column
  35 lowercasing behavior accordingly, as lower-cased column names do not work on
  36 case-sensitive databases.
  37
  38 To manually control case-sensitive mode, put:
  39
  40     preserve_case => 1|0
  41
  42 in your Loader options.
  43
  44 See L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case>.
  45
  46 B<NOTE:> this option used to be called C<case_sensitive_collation>, but has
  47 been renamed to a more generic option.
  48
  49 =cut
  50
  51 sub _setup {
  52     my $self = shift;
  53
  54     $self->next::method(@_);
  55
  56     return if defined $self->preserve_case;
  57
  58     my $dbh = $self->schema->storage->dbh;
  59
  60     # We use the sys.databases query for the general case, and fallback to
  61     # databasepropertyex() if for some reason sys.databases is not available,
  62     # which does not work over DBD::ODBC with unixODBC+FreeTDS.
  63     #
  64     # XXX why does databasepropertyex() not work over DBD::ODBC ?
  65     #
  66     # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx
  67     my ($collation_name) =
  68            eval { $dbh->selectrow_array('SELECT collation_name FROM sys.databases WHERE name = DB_NAME()') }
  69         || eval { $dbh->selectrow_array("SELECT CAST(databasepropertyex(DB_NAME(), 'Collation') AS VARCHAR)") };
  70
  71     if (not $collation_name) {
  72         warn <<'EOF';
  73
  74 WARNING: MSSQL Collation detection failed. Defaulting to case-insensitive mode.
  75 Override the 'preserve_case' attribute in your Loader options if needed.
  76
  77 See 'preserve_case' in
  78 perldoc DBIx::Class::Schema::Loader::Base
  79 EOF
  80         $self->preserve_case(0);
  81         return;
  82     }
  83
  84     my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/;
  85
  86     $self->preserve_case($case_sensitive ? 1 : 0);
  87 }
  88
  89 sub _tables_list {
  90     my ($self, $opts) = @_;
  91
  92     my $dbh = $self->schema->storage->dbh;
  93     my $sth = $dbh->prepare(<<'EOF');
  94 SELECT t.table_name
  95 FROM INFORMATION_SCHEMA.TABLES t
  96 WHERE t.table_schema = ?
  97 EOF
  98     $sth->execute($self->db_schema);
  99
 100     my @tables = map @$_, @{ $sth->fetchall_arrayref };
 101
 102     return $self->_filter_tables(\@tables, $opts);
 103 }
 104
 105 sub _table_pk_info {
 106     my ($self, $table) = @_;
 107     my $dbh = $self->schema->storage->dbh;
 108     my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
 109     $sth->execute;
 110
 111     my @keydata;
 112
 113     while (my $row = $sth->fetchrow_hashref) {
 114         push @keydata, $self->_lc($row->{COLUMN_NAME});
 115     }
 116
 117     return \@keydata;
 118 }
 119
 120 sub _table_fk_info {
 121     my ($self, $table) = @_;
 122
 123     my ($local_cols, $remote_cols, $remote_table, @rels, $sth);
 124     my $dbh = $self->schema->storage->dbh;
 125     eval {
 126         $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
 127         $sth->execute;
 128     };
 129
 130     while (my $row = eval { $sth->fetchrow_hashref }) {
 131         my $fk = $row->{FK_NAME};
 132         push @{$local_cols->{$fk}}, $self->_lc($row->{FKCOLUMN_NAME});
 133         push @{$remote_cols->{$fk}}, $self->_lc($row->{PKCOLUMN_NAME});
 134         $remote_table->{$fk} = $row->{PKTABLE_NAME};
 135     }
 136
 137     foreach my $fk (keys %$remote_table) {
 138         push @rels, {
 139                       local_columns => \@{$local_cols->{$fk}},
 140                       remote_columns => \@{$remote_cols->{$fk}},
 141                       remote_table => $remote_table->{$fk},
 142                     };
 143
 144     }
 145     return \@rels;
 146 }
 147
 148 sub _table_uniq_info {
 149     my ($self, $table) = @_;
 150
 151     my $dbh = $self->schema->storage->dbh;
 152     local $dbh->{FetchHashKeyName} = 'NAME_lc';
 153
 154     my $sth = $dbh->prepare(qq{
 155 SELECT ccu.constraint_name, ccu.column_name
 156 FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE ccu
 157 JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc on (ccu.constraint_name = tc.constraint_name)
 158 JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name)
 159 wHERE ccu.table_name = @{[ $dbh->quote($table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position
 160     });
 161     $sth->execute;
 162     my $constraints;
 163     while (my $row = $sth->fetchrow_hashref) {
 164         my $name = $row->{constraint_name};
 165         my $col  = $self->_lc($row->{column_name});
 166         push @{$constraints->{$name}}, $col;
 167     }
 168
 169     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 170     return \@uniqs;
 171 }
 172
 173 sub _columns_info_for {
 174     my $self    = shift;
 175     my ($table) = @_;
 176
 177     my $result = $self->next::method(@_);
 178
 179     my $dbh = $self->schema->storage->dbh;
 180
 181     while (my ($col, $info) = each %$result) {
 182 # get type info
 183         my $sth = $dbh->prepare(qq{
 184 SELECT character_maximum_length, data_type, datetime_precision
 185 FROM INFORMATION_SCHEMA.COLUMNS
 186 WHERE table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]}
 187         });
 188         $sth->execute;
 189         my ($char_max_length, $data_type, $datetime_precision) = $sth->fetchrow_array;
 190
 191         $info->{data_type} = $data_type;
 192
 193         if (defined $char_max_length) {
 194             $info->{size} = $char_max_length;
 195             $info->{size} = 0 if $char_max_length < 0;
 196         }
 197
 198 # find identities
 199         $sth = $dbh->prepare(qq{
 200 SELECT column_name
 201 FROM INFORMATION_SCHEMA.COLUMNS
 202 WHERE columnproperty(object_id(@{[ $dbh->quote($table) ]}, 'U'), @{[ $dbh->quote($col) ]}, 'IsIdentity') = 1
 203 AND table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]}
 204         });
 205         if (try { $sth->execute; $sth->fetchrow_array }) {
 206             $info->{is_auto_increment} = 1;
 207             $info->{data_type} =~ s/\s*identity//i;
 208             delete $info->{size};
 209         }
 210
 211 # fix types
 212         if ($data_type eq 'int') {
 213             $info->{data_type} = 'integer';
 214         }
 215         elsif ($data_type eq 'timestamp') {
 216             $info->{inflate_datetime} = 0;
 217         }
 218         elsif ($data_type =~ /^(?:numeric|decimal)\z/) {
 219             if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
 220                 delete $info->{size};
 221             }
 222         }
 223         elsif ($data_type eq 'float') {
 224             $info->{data_type} = 'double precision';
 225             delete $info->{size};
 226         }
 227         elsif ($data_type =~ /^(?:small)?datetime\z/) {
 228             # fixup for DBD::Sybase
 229             if ($info->{default_value} && $info->{default_value} eq '3') {
 230                 delete $info->{default_value};
 231             }
 232         }
 233         elsif ($data_type =~ /^(?:datetime(?:2|offset)|time)\z/) {
 234             $info->{size} = $datetime_precision;
 235
 236             delete $info->{size} if $info->{size} == 7;
 237         }
 238         elsif ($data_type eq 'varchar'   && $info->{size} == 0) {
 239             $info->{data_type} = 'text';
 240             delete $info->{size};
 241         }
 242         elsif ($data_type eq 'nvarchar'  && $info->{size} == 0) {
 243             $info->{data_type} = 'ntext';
 244             delete $info->{size};
 245         }
 246         elsif ($data_type eq 'varbinary' && $info->{size} == 0) {
 247             $info->{data_type} = 'image';
 248             delete $info->{size};
 249         }
 250
 251         if ($data_type !~ /^(?:n?char|n?varchar|binary|varbinary|numeric|decimal|float|datetime(?:2|offset)|time)\z/) {
 252             delete $info->{size};
 253         }
 254
 255 # get default
 256         $sth = $dbh->prepare(qq{
 257 SELECT column_default
 258 FROM INFORMATION_SCHEMA.COLUMNS
 259 wHERE table_name = @{[ $dbh->quote($table) ]} AND column_name = @{[ $dbh->quote($col) ]}
 260         });
 261         my ($default) = eval { $sth->execute; $sth->fetchrow_array };
 262
 263         if (defined $default) {
 264             # strip parens
 265             $default =~ s/^\( (.*) \)\z/$1/x;
 266
 267             # Literal strings are in ''s, numbers are in ()s (in some versions of
 268             # MSSQL, in others they are unquoted) everything else is a function.
 269             $info->{default_value} =
 270                 $default =~ /^['(] (.*) [)']\z/x ? $1 :
 271                     $default =~ /^\d/ ? $default : \$default;
 272
 273             if ((eval { lc ${ $info->{default_value} } }||'') eq 'getdate()') {
 274                 ${ $info->{default_value} } = 'current_timestamp';
 275
 276                 my $getdate = 'getdate()';
 277                 $info->{original}{default_value} = \$getdate;
 278             }
 279         }
 280     }
 281
 282     return $result;
 283 }
 284
 285 =head1 SEE ALSO
 286
 287 L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>,
 288 L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
 289 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 290 L<DBIx::Class::Schema::Loader::DBI>
 291
 292 =head1 AUTHOR
 293
 294 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 295
 296 =head1 LICENSE
 297
 298 This library is free software; you can redistribute it and/or modify it under
 299 the same terms as Perl itself.
 300
 301 =cut
 302
 303 1;
 304 # vim:et sts=4 sw=4 tw=0: