1 package DBIx::Class::Schema::Loader::DBI::MSSQL;
5 use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
8 use List::MoreUtils 'any';
11 use DBIx::Class::Schema::Loader::Table::Sybase ();
13 our $VERSION = '0.07010';
17 DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.
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
27 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base> for
30 =head1 CASE SENSITIVITY
32 Most MSSQL databases use C<CI> (case-insensitive) collation, for this reason
33 generated column names are lower-cased as this makes them easier to work with
36 We attempt to detect the database collation at startup for any database
37 included in L<db_schema|DBIx::Class::Schema::Loader::Base/db_schema>, and set
38 the column lowercasing behavior accordingly, as lower-cased column names do not
39 work on case-sensitive databases.
41 To manually control case-sensitive mode, put:
45 in your Loader options.
47 See L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case>.
49 B<NOTE:> this option used to be called C<case_sensitive_collation>, but has
50 been renamed to a more generic option.
54 sub _system_databases {
56 master model tempdb msdb
62 spt_fallback_db spt_fallback_dev spt_fallback_usg spt_monitor spt_values MSreplication_options
69 my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
71 FROM [$db].dbo.sysusers
75 return grep !/^(?:#|guest|INFORMATION_SCHEMA|sys)/, @$owners;
81 $self->next::method(@_);
83 my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
85 if (ref $self->db_schema eq 'HASH') {
86 if (keys %{ $self->db_schema } < 2) {
87 my ($db) = keys %{ $self->db_schema };
92 my $owners = $self->db_schema->{$db};
94 my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
96 FROM master.dbo.sysdatabases
101 foreach my $db_name (@$db_names) {
103 unless any { $_ eq $db_name } $self->_system_databases;
106 $self->db_schema({});
108 DB: foreach my $db (@dbs) {
109 if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
112 foreach my $owner (@$owners) {
114 if $self->dbh->selectrow_array(<<"EOF");
116 FROM [$db].dbo.sysusers
117 WHERE name = @{[ $self->dbh->quote($owner) ]}
121 next DB unless @owners;
123 $self->db_schema->{$db} = \@owners;
126 # for post-processing below
127 $self->db_schema->{$db} = '%';
131 $self->qualify_objects(1);
134 if ($db ne $current_db) {
135 $self->dbh->do("USE [$db]");
137 $self->qualify_objects(1);
142 $self->qualify_objects(1);
145 elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
146 my $owners = $self->db_schema;
147 $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ];
149 $self->qualify_objects(1) if @$owners > 1;
151 $self->db_schema({ $current_db => $owners });
154 foreach my $db (keys %{ $self->db_schema }) {
155 if ($self->db_schema->{$db} eq '%') {
156 $self->db_schema->{$db} = [ $self->_owners($db) ];
158 $self->qualify_objects(1);
162 if (not defined $self->preserve_case) {
163 foreach my $db (keys %{ $self->db_schema }) {
164 # We use the sys.databases query for the general case, and fallback to
165 # databasepropertyex() if for some reason sys.databases is not available,
166 # which does not work over DBD::ODBC with unixODBC+FreeTDS.
168 # XXX why does databasepropertyex() not work over DBD::ODBC ?
170 # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx
171 my ($collation_name) =
172 eval { $self->dbh->selectrow_array("SELECT collation_name FROM sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") }
173 || eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") };
175 if (not $collation_name) {
178 WARNING: MSSQL Collation detection failed for database '$db'. Defaulting to
179 case-insensitive mode. Override the 'preserve_case' attribute in your Loader
182 See 'preserve_case' in
183 perldoc DBIx::Class::Schema::Loader::Base
185 $self->preserve_case(0) unless $self->preserve_case;
188 my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/;
190 if ($case_sensitive && (not $self->preserve_case)) {
191 $self->preserve_case(1);
194 $self->preserve_case(0);
202 my ($self, $opts) = @_;
206 while (my ($db, $owners) = each %{ $self->db_schema }) {
207 foreach my $owner (@$owners) {
208 my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
210 FROM [$db].INFORMATION_SCHEMA.TABLES
211 WHERE table_schema = @{[ $self->dbh->quote($owner) ]}
214 TABLE: foreach my $table_name (@$table_names) {
215 next TABLE if any { $_ eq $table_name } $self->_system_tables;
217 push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
227 return $self->_filter_tables(\@tables, $opts);
231 my ($self, $table) = @_;
233 my $db = $table->database;
235 return $self->dbh->selectcol_arrayref(<<"EOF")
236 SELECT kcu.column_name
237 FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
238 JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
239 ON kcu.table_name = tc.table_name
240 AND kcu.table_schema = tc.table_schema
241 AND kcu.constraint_name = tc.constraint_name
242 WHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]}
243 AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
244 AND tc.constraint_type = 'PRIMARY KEY'
245 ORDER BY kcu.ordinal_position
250 my ($self, $table) = @_;
252 my $db = $table->database;
254 my $sth = $self->dbh->prepare(<<"EOF");
255 SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name, fk_kcu.column_name, uk_kcu.column_name
256 FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc
257 JOIN [$db].INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
258 ON rc.constraint_name = fk_tc.constraint_name
259 AND rc.constraint_schema = fk_tc.table_schema
260 JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE fk_kcu
261 ON fk_kcu.constraint_name = fk_tc.constraint_name
262 AND fk_kcu.table_name = fk_tc.table_name
263 AND fk_kcu.table_schema = fk_tc.table_schema
264 JOIN [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS uk_tc
265 ON uk_tc.constraint_name = rc.unique_constraint_name
266 AND uk_tc.table_schema = rc.unique_constraint_schema
267 JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE uk_kcu
268 ON uk_kcu.constraint_name = rc.unique_constraint_name
269 AND uk_kcu.ordinal_position = fk_kcu.ordinal_position
270 AND uk_kcu.table_name = uk_tc.table_name
271 AND uk_kcu.table_schema = rc.unique_constraint_schema
272 WHERE fk_tc.table_name = @{[ $self->dbh->quote($table->name) ]}
273 AND fk_tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
274 ORDER BY fk_kcu.ordinal_position
281 while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) {
282 push @{ $rels{$fk}{local_columns} }, $col;
283 push @{ $rels{$fk}{remote_columns} }, $remote_col;
285 $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table::Sybase->new(
287 name => $remote_table,
289 schema => $remote_schema,
290 ) unless exists $rels{$fk}{remote_table};
293 return [ values %rels ];
296 sub _table_uniq_info {
297 my ($self, $table) = @_;
299 my $db = $table->database;
301 my $sth = $self->dbh->prepare(<<"EOF");
302 SELECT tc.constraint_name, kcu.column_name
303 FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
304 JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
305 ON kcu.constraint_name = tc.constraint_name
306 AND kcu.table_name = tc.table_name
307 AND kcu.table_schema = tc.table_schema
308 wHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]}
309 AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
310 AND tc.constraint_type = 'UNIQUE'
311 ORDER BY kcu.ordinal_position
318 while (my ($constr, $col) = $sth->fetchrow_array) {
319 push @{ $uniq{$constr} }, $self->_lc($col);
322 return [ map [ $_ => $uniq{$_} ], keys %uniq ];
325 sub _columns_info_for {
329 my $db = $table->database;
331 my $result = $self->next::method(@_);
333 while (my ($col, $info) = each %$result) {
335 my ($char_max_length, $data_type, $datetime_precision, $default) =
336 $self->dbh->selectrow_array(<<"EOF");
337 SELECT character_maximum_length, data_type, datetime_precision, column_default
338 FROM [$db].INFORMATION_SCHEMA.COLUMNS
339 WHERE table_name = @{[ $self->dbh->quote($table->name) ]}
340 AND table_schema = @{[ $self->dbh->quote($table->schema) ]}
341 AND column_name = @{[ $self->dbh->quote($col) ]}
344 $info->{data_type} = $data_type;
346 if (defined $char_max_length) {
347 $info->{size} = $char_max_length;
348 $info->{size} = 0 if $char_max_length < 0;
352 my ($is_identity) = $self->dbh->selectrow_array(<<"EOF");
354 FROM [$db].sys.columns
357 FROM [$db].sys.objects
358 WHERE name = @{[ $self->dbh->quote($table->name) ]}
361 FROM [$db].sys.schemas
362 WHERE name = @{[ $self->dbh->quote($table->schema) ]}
364 ) AND name = @{[ $self->dbh->quote($col) ]}
367 $info->{is_auto_increment} = 1;
368 $info->{data_type} =~ s/\s*identity//i;
369 delete $info->{size};
373 if ($data_type eq 'int') {
374 $info->{data_type} = 'integer';
376 elsif ($data_type eq 'timestamp') {
377 $info->{inflate_datetime} = 0;
379 elsif ($data_type =~ /^(?:numeric|decimal)\z/) {
380 if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
381 delete $info->{size};
384 elsif ($data_type eq 'float') {
385 $info->{data_type} = 'double precision';
386 delete $info->{size};
388 elsif ($data_type =~ /^(?:small)?datetime\z/) {
389 # fixup for DBD::Sybase
390 if ($info->{default_value} && $info->{default_value} eq '3') {
391 delete $info->{default_value};
394 elsif ($data_type =~ /^(?:datetime(?:2|offset)|time)\z/) {
395 $info->{size} = $datetime_precision;
397 delete $info->{size} if $info->{size} == 7;
399 elsif ($data_type eq 'varchar' && $info->{size} == 0) {
400 $info->{data_type} = 'text';
401 delete $info->{size};
403 elsif ($data_type eq 'nvarchar' && $info->{size} == 0) {
404 $info->{data_type} = 'ntext';
405 delete $info->{size};
407 elsif ($data_type eq 'varbinary' && $info->{size} == 0) {
408 $info->{data_type} = 'image';
409 delete $info->{size};
412 if ($data_type !~ /^(?:n?char|n?varchar|binary|varbinary|numeric|decimal|float|datetime(?:2|offset)|time)\z/) {
413 delete $info->{size};
416 if (defined $default) {
418 $default =~ s/^\( (.*) \)\z/$1/x;
420 # Literal strings are in ''s, numbers are in ()s (in some versions of
421 # MSSQL, in others they are unquoted) everything else is a function.
422 $info->{default_value} =
423 $default =~ /^['(] (.*) [)']\z/x ? $1 :
424 $default =~ /^\d/ ? $default : \$default;
426 if ((eval { lc ${ $info->{default_value} } }||'') eq 'getdate()') {
427 ${ $info->{default_value} } = 'current_timestamp';
429 my $getdate = 'getdate()';
430 $info->{original}{default_value} = \$getdate;
440 L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>,
441 L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
442 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
443 L<DBIx::Class::Schema::Loader::DBI>
447 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
451 This library is free software; you can redistribute it and/or modify it under
452 the same terms as Perl itself.
457 # vim:et sts=4 sw=4 tw=0: