Commit | Line | Data |
fe67d343 |
1 | package DBIx::Class::Schema::Loader::DBI::MSSQL; |
2 | |
3 | use strict; |
4 | use warnings; |
de82711a |
5 | use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; |
942bd5e0 |
6 | use mro 'c3'; |
afcd3c32 |
7 | use Try::Tiny; |
c4a69b87 |
8 | use List::MoreUtils 'any'; |
afcd3c32 |
9 | use namespace::clean; |
fe67d343 |
10 | |
c4a69b87 |
11 | use DBIx::Class::Schema::Loader::Table::Sybase (); |
12 | |
bb46cd4b |
13 | our $VERSION = '0.07021'; |
fe67d343 |
14 | |
15 | =head1 NAME |
16 | |
17 | DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation. |
18 | |
acfcc1fb |
19 | =head1 DESCRIPTION |
fe67d343 |
20 | |
acfcc1fb |
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>. |
fe67d343 |
26 | |
acfcc1fb |
27 | See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base> for |
28 | usage information. |
fe67d343 |
29 | |
b065e3df |
30 | =head1 CASE SENSITIVITY |
31 | |
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 |
34 | in L<DBIx::Class>. |
35 | |
c4a69b87 |
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. |
b065e3df |
40 | |
81ade4d9 |
41 | To manually control case-sensitive mode, put: |
b065e3df |
42 | |
bc1cb85e |
43 | preserve_case => 1|0 |
b065e3df |
44 | |
103e90da |
45 | in your Loader options. |
b065e3df |
46 | |
bc1cb85e |
47 | See L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case>. |
fe67d343 |
48 | |
bc1cb85e |
49 | B<NOTE:> this option used to be called C<case_sensitive_collation>, but has |
50 | been renamed to a more generic option. |
3559ae79 |
51 | |
bc1cb85e |
52 | =cut |
3559ae79 |
53 | |
c4a69b87 |
54 | sub _system_databases { |
55 | return (qw/ |
56 | master model tempdb msdb |
57 | /); |
58 | } |
59 | |
60 | sub _system_tables { |
61 | return (qw/ |
62 | spt_fallback_db spt_fallback_dev spt_fallback_usg spt_monitor spt_values MSreplication_options |
63 | /); |
64 | } |
65 | |
66 | sub _owners { |
67 | my ($self, $db) = @_; |
68 | |
69 | my $owners = $self->dbh->selectcol_arrayref(<<"EOF"); |
70 | SELECT name |
71 | FROM [$db].dbo.sysusers |
72 | WHERE uid <> gid |
73 | EOF |
74 | |
75 | return grep !/^(?:#|guest|INFORMATION_SCHEMA|sys)/, @$owners; |
76 | } |
77 | |
116431d6 |
78 | sub _current_db { |
79 | my $self = shift; |
80 | return ($self->dbh->selectrow_array('SELECT db_name()'))[0]; |
81 | } |
82 | |
83 | sub _switch_db { |
84 | my ($self, $db) = @_; |
85 | $self->dbh->do("use [$db]"); |
86 | } |
87 | |
3559ae79 |
88 | sub _setup { |
89 | my $self = shift; |
90 | |
bc1cb85e |
91 | $self->next::method(@_); |
3559ae79 |
92 | |
116431d6 |
93 | my $current_db = $self->_current_db; |
b065e3df |
94 | |
c4a69b87 |
95 | if (ref $self->db_schema eq 'HASH') { |
96 | if (keys %{ $self->db_schema } < 2) { |
97 | my ($db) = keys %{ $self->db_schema }; |
3559ae79 |
98 | |
c4a69b87 |
99 | $db ||= $current_db; |
b7a0a040 |
100 | |
c4a69b87 |
101 | if ($db eq '%') { |
102 | my $owners = $self->db_schema->{$db}; |
b065e3df |
103 | |
c4a69b87 |
104 | my $db_names = $self->dbh->selectcol_arrayref(<<'EOF'); |
105 | SELECT name |
106 | FROM master.dbo.sysdatabases |
107 | EOF |
bc1cb85e |
108 | |
c4a69b87 |
109 | my @dbs; |
110 | |
111 | foreach my $db_name (@$db_names) { |
112 | push @dbs, $db_name |
113 | unless any { $_ eq $db_name } $self->_system_databases; |
114 | } |
115 | |
116 | $self->db_schema({}); |
117 | |
118 | DB: foreach my $db (@dbs) { |
119 | if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) { |
120 | my @owners; |
121 | |
122 | foreach my $owner (@$owners) { |
123 | push @owners, $owner |
124 | if $self->dbh->selectrow_array(<<"EOF"); |
125 | SELECT name |
126 | FROM [$db].dbo.sysusers |
127 | WHERE name = @{[ $self->dbh->quote($owner) ]} |
b065e3df |
128 | EOF |
c4a69b87 |
129 | } |
130 | |
131 | next DB unless @owners; |
132 | |
133 | $self->db_schema->{$db} = \@owners; |
134 | } |
135 | else { |
136 | # for post-processing below |
137 | $self->db_schema->{$db} = '%'; |
138 | } |
139 | } |
140 | |
141 | $self->qualify_objects(1); |
142 | } |
143 | else { |
144 | if ($db ne $current_db) { |
145 | $self->dbh->do("USE [$db]"); |
146 | |
147 | $self->qualify_objects(1); |
148 | } |
149 | } |
150 | } |
151 | else { |
152 | $self->qualify_objects(1); |
153 | } |
154 | } |
155 | elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) { |
156 | my $owners = $self->db_schema; |
157 | $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ]; |
158 | |
159 | $self->qualify_objects(1) if @$owners > 1; |
160 | |
161 | $self->db_schema({ $current_db => $owners }); |
b7a0a040 |
162 | } |
3559ae79 |
163 | |
c4a69b87 |
164 | foreach my $db (keys %{ $self->db_schema }) { |
165 | if ($self->db_schema->{$db} eq '%') { |
166 | $self->db_schema->{$db} = [ $self->_owners($db) ]; |
167 | |
168 | $self->qualify_objects(1); |
169 | } |
170 | } |
3559ae79 |
171 | |
c4a69b87 |
172 | if (not defined $self->preserve_case) { |
173 | foreach my $db (keys %{ $self->db_schema }) { |
174 | # We use the sys.databases query for the general case, and fallback to |
175 | # databasepropertyex() if for some reason sys.databases is not available, |
176 | # which does not work over DBD::ODBC with unixODBC+FreeTDS. |
177 | # |
178 | # XXX why does databasepropertyex() not work over DBD::ODBC ? |
179 | # |
180 | # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx |
116431d6 |
181 | |
182 | my $current_db = $self->_current_db; |
183 | |
184 | $self->_switch_db($db); |
185 | |
186 | my $collation_name = |
187 | (eval { $self->dbh->selectrow_array("SELECT collation_name FROM [$db].sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") })[0] |
188 | || (eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") })[0]; |
189 | |
190 | $self->_switch_db($current_db); |
c4a69b87 |
191 | |
192 | if (not $collation_name) { |
193 | warn <<"EOF"; |
194 | |
195 | WARNING: MSSQL Collation detection failed for database '$db'. Defaulting to |
196 | case-insensitive mode. Override the 'preserve_case' attribute in your Loader |
197 | options if needed. |
198 | |
199 | See 'preserve_case' in |
200 | perldoc DBIx::Class::Schema::Loader::Base |
201 | EOF |
202 | $self->preserve_case(0) unless $self->preserve_case; |
203 | } |
204 | else { |
205 | my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/; |
206 | |
207 | if ($case_sensitive && (not $self->preserve_case)) { |
208 | $self->preserve_case(1); |
209 | } |
210 | else { |
211 | $self->preserve_case(0); |
212 | } |
213 | } |
214 | } |
215 | } |
3559ae79 |
216 | } |
217 | |
acfcc1fb |
218 | sub _tables_list { |
bfb43060 |
219 | my ($self, $opts) = @_; |
fe67d343 |
220 | |
c4a69b87 |
221 | my @tables; |
222 | |
223 | while (my ($db, $owners) = each %{ $self->db_schema }) { |
224 | foreach my $owner (@$owners) { |
225 | my $table_names = $self->dbh->selectcol_arrayref(<<"EOF"); |
226 | SELECT table_name |
227 | FROM [$db].INFORMATION_SCHEMA.TABLES |
228 | WHERE table_schema = @{[ $self->dbh->quote($owner) ]} |
acfcc1fb |
229 | EOF |
fe67d343 |
230 | |
c4a69b87 |
231 | TABLE: foreach my $table_name (@$table_names) { |
232 | next TABLE if any { $_ eq $table_name } $self->_system_tables; |
233 | |
234 | push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new( |
235 | loader => $self, |
236 | name => $table_name, |
237 | database => $db, |
238 | schema => $owner, |
239 | ); |
240 | } |
241 | } |
242 | } |
acfcc1fb |
243 | |
bfb43060 |
244 | return $self->_filter_tables(\@tables, $opts); |
acfcc1fb |
245 | } |
fe67d343 |
246 | |
fe67d343 |
247 | sub _table_pk_info { |
248 | my ($self, $table) = @_; |
fe67d343 |
249 | |
c4a69b87 |
250 | my $db = $table->database; |
251 | |
116431d6 |
252 | my $pk = $self->dbh->selectcol_arrayref(<<"EOF"); |
c4a69b87 |
253 | SELECT kcu.column_name |
254 | FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc |
255 | JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu |
256 | ON kcu.table_name = tc.table_name |
257 | AND kcu.table_schema = tc.table_schema |
258 | AND kcu.constraint_name = tc.constraint_name |
259 | WHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]} |
260 | AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]} |
261 | AND tc.constraint_type = 'PRIMARY KEY' |
262 | ORDER BY kcu.ordinal_position |
263 | EOF |
116431d6 |
264 | |
265 | $pk = [ map $self->_lc($_), @$pk ]; |
266 | |
267 | return $pk; |
fe67d343 |
268 | } |
269 | |
270 | sub _table_fk_info { |
271 | my ($self, $table) = @_; |
272 | |
c4a69b87 |
273 | my $db = $table->database; |
274 | |
275 | my $sth = $self->dbh->prepare(<<"EOF"); |
276 | SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name, fk_kcu.column_name, uk_kcu.column_name |
277 | FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc |
278 | JOIN [$db].INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc |
279 | ON rc.constraint_name = fk_tc.constraint_name |
280 | AND rc.constraint_schema = fk_tc.table_schema |
281 | JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE fk_kcu |
282 | ON fk_kcu.constraint_name = fk_tc.constraint_name |
283 | AND fk_kcu.table_name = fk_tc.table_name |
284 | AND fk_kcu.table_schema = fk_tc.table_schema |
285 | JOIN [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS uk_tc |
286 | ON uk_tc.constraint_name = rc.unique_constraint_name |
287 | AND uk_tc.table_schema = rc.unique_constraint_schema |
288 | JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE uk_kcu |
289 | ON uk_kcu.constraint_name = rc.unique_constraint_name |
290 | AND uk_kcu.ordinal_position = fk_kcu.ordinal_position |
291 | AND uk_kcu.table_name = uk_tc.table_name |
292 | AND uk_kcu.table_schema = rc.unique_constraint_schema |
293 | WHERE fk_tc.table_name = @{[ $self->dbh->quote($table->name) ]} |
294 | AND fk_tc.table_schema = @{[ $self->dbh->quote($table->schema) ]} |
295 | ORDER BY fk_kcu.ordinal_position |
296 | EOF |
fe67d343 |
297 | |
c4a69b87 |
298 | $sth->execute; |
fe67d343 |
299 | |
c4a69b87 |
300 | my %rels; |
301 | |
302 | while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) { |
116431d6 |
303 | push @{ $rels{$fk}{local_columns} }, $self->_lc($col); |
304 | push @{ $rels{$fk}{remote_columns} }, $self->_lc($remote_col); |
c4a69b87 |
305 | |
306 | $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table::Sybase->new( |
307 | loader => $self, |
308 | name => $remote_table, |
309 | database => $db, |
310 | schema => $remote_schema, |
311 | ) unless exists $rels{$fk}{remote_table}; |
fe67d343 |
312 | } |
c4a69b87 |
313 | |
314 | return [ values %rels ]; |
fe67d343 |
315 | } |
316 | |
317 | sub _table_uniq_info { |
318 | my ($self, $table) = @_; |
319 | |
c4a69b87 |
320 | my $db = $table->database; |
321 | |
322 | my $sth = $self->dbh->prepare(<<"EOF"); |
323 | SELECT tc.constraint_name, kcu.column_name |
324 | FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc |
325 | JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu |
326 | ON kcu.constraint_name = tc.constraint_name |
327 | AND kcu.table_name = tc.table_name |
328 | AND kcu.table_schema = tc.table_schema |
329 | wHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]} |
330 | AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]} |
331 | AND tc.constraint_type = 'UNIQUE' |
332 | ORDER BY kcu.ordinal_position |
333 | EOF |
020f3c3a |
334 | |
fe67d343 |
335 | $sth->execute; |
c4a69b87 |
336 | |
337 | my %uniq; |
338 | |
339 | while (my ($constr, $col) = $sth->fetchrow_array) { |
340 | push @{ $uniq{$constr} }, $self->_lc($col); |
fe67d343 |
341 | } |
342 | |
c4a69b87 |
343 | return [ map [ $_ => $uniq{$_} ], keys %uniq ]; |
fe67d343 |
344 | } |
345 | |
9c9197d6 |
346 | sub _columns_info_for { |
347 | my $self = shift; |
348 | my ($table) = @_; |
349 | |
c4a69b87 |
350 | my $db = $table->database; |
9c9197d6 |
351 | |
c4a69b87 |
352 | my $result = $self->next::method(@_); |
afcd3c32 |
353 | |
9c9197d6 |
354 | while (my ($col, $info) = each %$result) { |
afcd3c32 |
355 | # get type info |
c4a69b87 |
356 | my ($char_max_length, $data_type, $datetime_precision, $default) = |
357 | $self->dbh->selectrow_array(<<"EOF"); |
358 | SELECT character_maximum_length, data_type, datetime_precision, column_default |
359 | FROM [$db].INFORMATION_SCHEMA.COLUMNS |
360 | WHERE table_name = @{[ $self->dbh->quote($table->name) ]} |
361 | AND table_schema = @{[ $self->dbh->quote($table->schema) ]} |
116431d6 |
362 | AND @{[ $self->preserve_case ? |
363 | "column_name = @{[ $self->dbh->quote($col) ]}" |
364 | : |
365 | "lower(column_name) = @{[ $self->dbh->quote(lc $col) ]}" ]} |
c4a69b87 |
366 | EOF |
afcd3c32 |
367 | |
368 | $info->{data_type} = $data_type; |
369 | |
370 | if (defined $char_max_length) { |
371 | $info->{size} = $char_max_length; |
372 | $info->{size} = 0 if $char_max_length < 0; |
373 | } |
020f3c3a |
374 | |
81ade4d9 |
375 | # find identities |
c4a69b87 |
376 | my ($is_identity) = $self->dbh->selectrow_array(<<"EOF"); |
377 | SELECT is_identity |
378 | FROM [$db].sys.columns |
379 | WHERE object_id = ( |
380 | SELECT object_id |
381 | FROM [$db].sys.objects |
382 | WHERE name = @{[ $self->dbh->quote($table->name) ]} |
383 | AND schema_id = ( |
384 | SELECT schema_id |
385 | FROM [$db].sys.schemas |
386 | WHERE name = @{[ $self->dbh->quote($table->schema) ]} |
387 | ) |
116431d6 |
388 | ) AND @{[ $self->preserve_case ? |
389 | "name = @{[ $self->dbh->quote($col) ]}" |
390 | : |
391 | "lower(name) = @{[ $self->dbh->quote(lc $col) ]}" ]} |
c4a69b87 |
392 | EOF |
393 | if ($is_identity) { |
9c9197d6 |
394 | $info->{is_auto_increment} = 1; |
395 | $info->{data_type} =~ s/\s*identity//i; |
396 | delete $info->{size}; |
397 | } |
fe67d343 |
398 | |
81ade4d9 |
399 | # fix types |
afcd3c32 |
400 | if ($data_type eq 'int') { |
81ade4d9 |
401 | $info->{data_type} = 'integer'; |
402 | } |
afcd3c32 |
403 | elsif ($data_type eq 'timestamp') { |
81ade4d9 |
404 | $info->{inflate_datetime} = 0; |
405 | } |
afcd3c32 |
406 | elsif ($data_type =~ /^(?:numeric|decimal)\z/) { |
81ade4d9 |
407 | if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) { |
408 | delete $info->{size}; |
409 | } |
410 | } |
afcd3c32 |
411 | elsif ($data_type eq 'float') { |
81ade4d9 |
412 | $info->{data_type} = 'double precision'; |
afcd3c32 |
413 | delete $info->{size}; |
81ade4d9 |
414 | } |
afcd3c32 |
415 | elsif ($data_type =~ /^(?:small)?datetime\z/) { |
81ade4d9 |
416 | # fixup for DBD::Sybase |
417 | if ($info->{default_value} && $info->{default_value} eq '3') { |
418 | delete $info->{default_value}; |
419 | } |
420 | } |
afcd3c32 |
421 | elsif ($data_type =~ /^(?:datetime(?:2|offset)|time)\z/) { |
ae38ed69 |
422 | $info->{size} = $datetime_precision; |
81ade4d9 |
423 | |
424 | delete $info->{size} if $info->{size} == 7; |
425 | } |
afcd3c32 |
426 | elsif ($data_type eq 'varchar' && $info->{size} == 0) { |
ae38ed69 |
427 | $info->{data_type} = 'text'; |
428 | delete $info->{size}; |
81ade4d9 |
429 | } |
afcd3c32 |
430 | elsif ($data_type eq 'nvarchar' && $info->{size} == 0) { |
ae38ed69 |
431 | $info->{data_type} = 'ntext'; |
432 | delete $info->{size}; |
433 | } |
afcd3c32 |
434 | elsif ($data_type eq 'varbinary' && $info->{size} == 0) { |
ae38ed69 |
435 | $info->{data_type} = 'image'; |
436 | delete $info->{size}; |
81ade4d9 |
437 | } |
438 | |
afcd3c32 |
439 | if ($data_type !~ /^(?:n?char|n?varchar|binary|varbinary|numeric|decimal|float|datetime(?:2|offset)|time)\z/) { |
81ade4d9 |
440 | delete $info->{size}; |
441 | } |
442 | |
9c9197d6 |
443 | if (defined $default) { |
444 | # strip parens |
445 | $default =~ s/^\( (.*) \)\z/$1/x; |
446 | |
447 | # Literal strings are in ''s, numbers are in ()s (in some versions of |
448 | # MSSQL, in others they are unquoted) everything else is a function. |
449 | $info->{default_value} = |
450 | $default =~ /^['(] (.*) [)']\z/x ? $1 : |
451 | $default =~ /^\d/ ? $default : \$default; |
8a64178e |
452 | |
268cc246 |
453 | if ((eval { lc ${ $info->{default_value} } }||'') eq 'getdate()') { |
6e566cc4 |
454 | ${ $info->{default_value} } = 'current_timestamp'; |
701cd3e3 |
455 | |
456 | my $getdate = 'getdate()'; |
457 | $info->{original}{default_value} = \$getdate; |
8a64178e |
458 | } |
9c9197d6 |
459 | } |
5c6fb0a1 |
460 | } |
461 | |
9c9197d6 |
462 | return $result; |
fe67d343 |
463 | } |
464 | |
fe67d343 |
465 | =head1 SEE ALSO |
466 | |
acfcc1fb |
467 | L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>, |
468 | L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>, |
fe67d343 |
469 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
470 | L<DBIx::Class::Schema::Loader::DBI> |
471 | |
472 | =head1 AUTHOR |
473 | |
9cc8e7e1 |
474 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
fe67d343 |
475 | |
be80bba7 |
476 | =head1 LICENSE |
0852b7b8 |
477 | |
be80bba7 |
478 | This library is free software; you can redistribute it and/or modify it under |
479 | the same terms as Perl itself. |
0852b7b8 |
480 | |
fe67d343 |
481 | =cut |
482 | |
483 | 1; |
bfb43060 |
484 | # vim:et sts=4 sw=4 tw=0: |