From: Rafael Kitover <rkitover@cpan.org>
Date: Sun, 9 Sep 2012 13:12:08 +0000 (-0400)
Subject: detect inline deferrable FKs for SQLite
X-Git-Tag: 0.07032~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=add8bcf0aabf53cddb452eda4d3b25a35bf57d25;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

detect inline deferrable FKs for SQLite

The previous attempt to detect DEFERRABLE on FKs only detected for
FOREIGN KEY clauses in DDL, not for inline constraints such as:

    int foo references bar(id) deferrable

add code and tests to detect inline FKs as well.
---

diff --git a/Changes b/Changes
index 28cbf8b..bb3dd54 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - SQLite: detect is_deferrable for inline FKs
         - support coderefs for relationship_attrs
 
 0.07031  2012-09-06 15:07:08
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
index 392d8bb..b548613 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
@@ -147,8 +147,8 @@ where name = ? and tbl_name = ?
 EOF
 
     foreach my $fk (@rels) {
-        my $local_cols  = '"?' . (join '"? \s* , \s* "?', @{ $fk->{local_columns} })        . '"?';
-        my $remote_cols = '"?' . (join '"? \s* , \s* "?', @{ $fk->{remote_columns} || [] }) . '"?';
+        my $local_cols  = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $fk->{local_columns} })        . '"?';
+        my $remote_cols = '"?' . (join '"? \s* , \s* "?', map quotemeta, @{ $fk->{remote_columns} || [] }) . '"?';
         my ($deferrable_clause) = $ddl =~ /
                 foreign \s+ key \s* \( \s* $local_cols \s* \) \s* references \s* (?:\S+|".+?(?<!")") \s*
                 (?:\( \s* $remote_cols \s* \) \s*)?
@@ -164,7 +164,33 @@ EOF
             $fk->{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1;
         }
         else {
-            $fk->{attrs}{is_deferrable} = 0;
+            # check for inline constraint if 1 local column
+            if (@{ $fk->{local_columns} } == 1) {
+                my ($local_col)  = @{ $fk->{local_columns} };
+                my ($remote_col) = @{ $fk->{remote_columns} || [] };
+                $remote_col ||= '';
+
+                my ($deferrable_clause) = $ddl =~ /
+                    "?\Q$local_col\E"? \s* (?:\w+\s*)* (?: \( \s* \d\+ (?:\s*,\s*\d+)* \s* \) )? \s*
+                    references \s* (?:\S+|".+?(?<!")") (?:\s* \( \s* "?\Q$remote_col\E"? \s* \))? \s*
+                    (?:(?:
+                      on \s+ (?:delete|update) \s+ (?:set \s+ null|set \s+ default|cascade|restrict|no \s+ action)
+                    |
+                      match \s* (?:\S+|".+?(?<!")")
+                    ) \s*)*
+                    ((?:not)? \s* deferrable)?
+                /sxi;
+
+                if ($deferrable_clause) {
+                    $fk->{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1;
+                }
+                else {
+                    $fk->{attrs}{is_deferrable} = 0;
+                }
+            }
+            else {
+                $fk->{attrs}{is_deferrable} = 0;
+            }
         }
     }
 
diff --git a/t/10_01sqlite_common.t b/t/10_01sqlite_common.t
index 93a499c..c0b7434 100644
--- a/t/10_01sqlite_common.t
+++ b/t/10_01sqlite_common.t
@@ -127,12 +127,19 @@ my $tester = dbixcsl_common_tests->new(
                         on delete restrict on update set null deferrable
                 )
             },
+            # test inline constraint
+            q{
+                create table extra_loader_test10 (
+                    id integer primary key,
+                    eight_id int references extra_loader_test8(id) on delete restrict on update set null deferrable
+                )
+            },
         ],
         pre_drop_ddl => [ 'DROP VIEW extra_loader_test5' ],
         drop  => [ qw/extra_loader_test1 extra_loader_test2 extra_loader_test3
                       extra_loader_test4 extra_loader_test6 extra_loader_test7
-                      extra_loader_test8 extra_loader_test9 / ],
-        count => 15,
+                      extra_loader_test8 extra_loader_test9 extra_loader_test10 / ],
+        count => 19,
         run   => sub {
             my ($schema, $monikers, $classes) = @_;
 
@@ -181,6 +188,18 @@ my $tester = dbixcsl_common_tests->new(
 
             is $rel_info->{attrs}{is_deferrable}, 1,
                 'DEFERRABLE clause introspected correctly';
+
+            ok (($rel_info = $schema->source('ExtraLoaderTest10')->relationship_info('eight')),
+                'got rel info');
+
+            is $rel_info->{attrs}{on_delete}, 'RESTRICT',
+                'ON DELETE clause introspected correctly for inline FK';
+
+            is $rel_info->{attrs}{on_update}, 'SET NULL',
+                'ON UPDATE clause introspected correctly for inline FK';
+
+            is $rel_info->{attrs}{is_deferrable}, 1,
+                'DEFERRABLE clause introspected correctly for inline FK';
         },
     },
 );