FK ON clause introspection for MSSQL

Augment the _table_fk_info code which uses information_schema to get the
delete_rule and update_rule, similarly to how it was done for
PostgreSQL. MSSQL does not have DEFERRABLE, but it has a way to disable
FK constraints on a table temporarily, which we will implement for
$storage->with_deferred_fk_checks for MSSQL in DBIC. For this reason,
is_deferrable still defaults to 1 for MSSQL.

diff --git a/Changes b/Changes
index e2159e9..208d997 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - MSSQL: introspect ON DELETE/UPDATE clauses for foreign keys
+        - MSSQL WARNING: the default for on_delete/on_update is now 'NO ACTION'
+          not 'CASCADE'.
+
 0.07027  2012-08-26 22:39:45
         - PostgreSQL: introspect ON DELETE/UPDATE clauses for foreign keys and
           the DEFERRABLE clause.

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
index b5505cb..4b1554e 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
@@ -273,7 +273,8 @@ sub _table_fk_info {
     my $db = $table->database;
 
     my $sth = $self->dbh->prepare(<<"EOF");
-SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name, fk_kcu.column_name, uk_kcu.column_name
+SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name,
+       fk_kcu.column_name, uk_kcu.column_name, rc.delete_rule, rc.update_rule
 FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc
 JOIN [$db].INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
     ON rc.constraint_name = fk_tc.constraint_name
@@ -299,7 +300,8 @@ EOF
 
     my %rels;
 
-    while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) {
+    while (my ($fk, $remote_schema, $remote_table, $col, $remote_col,
+               $delete_rule, $update_rule) = $sth->fetchrow_array) {
         push @{ $rels{$fk}{local_columns}  }, $self->_lc($col);
         push @{ $rels{$fk}{remote_columns} }, $self->_lc($remote_col);
         
@@ -309,6 +311,12 @@ EOF
             database => $db,
             schema   => $remote_schema,
         ) unless exists $rels{$fk}{remote_table};
+
+        $rels{$fk}{attrs} ||= {
+            on_delete     => uc $delete_rule,
+            on_update     => uc $update_rule,
+            is_deferrable => 1 # constraints can be temporarily disabled, but DEFERRABLE is not supported
+        };
     }
 
     return [ values %rels ];

diff --git a/t/10_03pg_common.t b/t/10_03pg_common.t
index ed1ed93..e3a8b03 100644 (file)
--- a/t/10_03pg_common.t
+++ b/t/10_03pg_common.t
@@ -237,12 +237,11 @@ my $tester = dbixcsl_common_tests->new(
             q{
                 create table pg_loader_test10 (
                     id bigserial primary key,
-                    eleven_id int,
-                    foreign key (eleven_id) references pg_loader_test9(id)
+                    nine_id int,
+                    foreign key (nine_id) references pg_loader_test9(id)
                         on delete restrict on update set null deferrable
                 )
             },
-
         ],
         pre_drop_ddl => [
             'DROP SCHEMA dbicsl_test CASCADE',
@@ -279,7 +278,7 @@ my $tester = dbixcsl_common_tests->new(
                 'long table comment is in DESCRIPTION';
 
             # test on delete/update fk clause introspection
-            ok ((my $rel_info = $schema->source('PgLoaderTest10')->relationship_info('eleven')),
+            ok ((my $rel_info = $schema->source('PgLoaderTest10')->relationship_info('nine')),
                 'got rel info');
 
             is $rel_info->{attrs}{on_delete}, 'RESTRICT',

diff --git a/t/10_07mssql_common.t b/t/10_07mssql_common.t
index 13c57d4..6382fc6 100644 (file)
--- a/t/10_07mssql_common.t
+++ b/t/10_07mssql_common.t
@@ -94,6 +94,7 @@ my $tester = dbixcsl_common_tests->new(
     preserve_case_mode_is_exclusive => 1,
     quote_char => [ qw/[ ]/ ],
     basic_date_datatype => ($common_version >= 10) ? 'DATE' : 'SMALLDATETIME',
+    default_on_clause => 'NO ACTION',
     data_types => {
         # http://msdn.microsoft.com/en-us/library/ms187752.aspx
 
@@ -200,6 +201,20 @@ my $tester = dbixcsl_common_tests->new(
                     [Five_Id] INT REFERENCES [MSSQL_Loader_Test5] ([Id])
                 )
             },
+            # 8 through 12 are used for the multi-schema tests and 13 through 16 are used for multi-db tests
+            q{
+                create table mssql_loader_test17 (
+                    id int identity primary key
+                )
+            },
+            q{
+                create table mssql_loader_test18 (
+                    id int identity primary key,
+                    seventeen_id int,
+                    foreign key (seventeen_id) references mssql_loader_test17(id)
+                        on delete set default on update set null
+                )
+            },
         ],
         pre_drop_ddl => [
             'CREATE TABLE mssql_loader_test3 (id INT IDENTITY NOT NULL PRIMARY KEY)',
@@ -210,8 +225,10 @@ my $tester = dbixcsl_common_tests->new(
             'mssql_loader_test3',
             'MSSQL_Loader_Test6',
             'MSSQL_Loader_Test5',
+            'mssql_loader_test17',
+            'mssql_loader_test18',
         ],
-        count  => 10 + 30 * 2 + 26 * 2, # extra + multi-schema + mutli-db
+        count  => 14 + 30 * 2 + 26 * 2, # extra + multi-schema + mutli-db
         run    => sub {
             my ($monikers, $classes, $self);
             ($schema, $monikers, $classes, $self) = @_;
@@ -286,6 +303,19 @@ my $tester = dbixcsl_common_tests->new(
             } qr/Can't find source/,
                 'no source registered for bad view';
 
+            # test on delete/update fk clause introspection
+            ok ((my $rel_info = $schema->source('MssqlLoaderTest18')->relationship_info('seventeen')),
+                'got rel info');
+
+            is $rel_info->{attrs}{on_delete}, 'SET DEFAULT',
+                'ON DELETE clause introspected correctly';
+
+            is $rel_info->{attrs}{on_update}, 'SET NULL',
+                'ON UPDATE clause introspected correctly';
+
+            is $rel_info->{attrs}{is_deferrable}, 1,
+                'is_deferrable defaults to 1';
+
             SKIP: {
                 my $dbh = $schema->storage->dbh;