introspect ON/DEFERRABLE FK clauses for SQLite

The ON clauses are simple to get, pragma foreign_key_list returns them,
but for the DEFERRABLE clause we have to parse the table DDL from
sqlite_master, a bit hairy but should be correct.

diff --git a/Changes b/Changes
index 1704655..57f72f1 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - SQLite: introspect ON DELETE/UPDATE and DEFERRABLE clauses
+        - SQLite WARNING: the default for on_delete/on_update is now 'NO ACTION'
+          not 'CASCADE', and the default for is_deferrable is now 0 not 1.
+
 0.07028  2012-08-30 05:32:42
         - MSSQL: introspect ON DELETE/UPDATE clauses for foreign keys
         - MSSQL WARNING: the default for on_delete/on_update is now 'NO ACTION'

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
index ad747d5..e6ef0a9 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
@@ -11,7 +11,7 @@ our $VERSION = '0.07028';
 
 =head1 NAME
 
-DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI 
+DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI
 Oracle Implementation.
 
 =head1 DESCRIPTION
@@ -100,7 +100,7 @@ EOF
         my $constr_col  = $self->_lc($constr->[1]);
         push @{$constr_names{$constr_name}}, $constr_col;
     }
-    
+
     my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names;
     return \@uniqs;
 }
@@ -115,7 +115,7 @@ sub _table_comment {
 
     ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name);
 SELECT comments FROM all_tab_comments
-WHERE owner = ? 
+WHERE owner = ?
   AND table_name = ?
   AND (table_type = 'TABLE' OR table_type = 'VIEW')
 EOF
@@ -133,7 +133,7 @@ sub _column_comment {
 
     ($column_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($column_name));
 SELECT comments FROM all_col_comments
-WHERE owner = ? 
+WHERE owner = ?
   AND table_name = ?
   AND column_name = ?
 EOF
@@ -315,7 +315,7 @@ EOF
         elsif (lc($info->{data_type}) eq 'binary_float') {
             $info->{data_type}           = 'real';
             $info->{original}{data_type} = 'binary_float';
-        } 
+        }
         elsif (lc($info->{data_type}) eq 'binary_double') {
             $info->{data_type}           = 'double precision';
             $info->{original}{data_type} = 'binary_double';

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
index 2499cf7..32e3f83 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
@@ -36,7 +36,7 @@ sub _setup {
     if (not defined $self->preserve_case) {
         $self->preserve_case(0);
     }
-    
+
     if ($self->db_schema) {
         warn <<'EOF';
 db_schema is not supported on SQLite, the option is implemented only for qualify_objects testing.
@@ -126,11 +126,48 @@ sub _table_fk_info {
 
         push @{ $rel->{local_columns} }, $self->_lc($fk->{from});
         push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to};
+
+        $rel->{attrs} ||= {
+            on_delete => uc $fk->{on_delete},
+            on_update => uc $fk->{on_update},
+        };
+
         warn "This is supposed to be the same rel but remote_table changed from ",
             $rel->{remote_table}->name, " to ", $fk->{table}
             if $rel->{remote_table}->name ne $fk->{table};
     }
     $sth->finish;
+
+    # now we need to determine whether each FK is DEFERRABLE, this can only be
+    # done by parsing the DDL from sqlite_master
+
+    my $ddl = $self->dbh->selectcol_arrayref(<<"EOF", undef, $table->name, $table->name)->[0];
+select sql from sqlite_master
+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 ($deferrable_clause) = $ddl =~ /
+                foreign \s+ key \s* \( \s* $local_cols \s* \) \s* references \s* (?:\S+|".+?(?<!")") \s*
+                (?:\( \s* $remote_cols \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;
+        }
+    }
+
     return \@rels;
 }
 
@@ -205,3 +242,4 @@ the same terms as Perl itself.
 =cut
 
 1;
+# vim:et sts=4 sw=4 tw=0:

diff --git a/t/10_01sqlite_common.t b/t/10_01sqlite_common.t
index e588ded..93a499c 100644 (file)
--- a/t/10_01sqlite_common.t
+++ b/t/10_01sqlite_common.t
@@ -17,6 +17,8 @@ my $tester = dbixcsl_common_tests->new(
         on_connect_do => [ 'PRAGMA foreign_keys = ON', 'PRAGMA synchronous = OFF', ]
     },
     loader_options  => { preserve_case => 1 },
+    default_is_deferrable => 0,
+    default_on_clause => 'NO ACTION',
     data_types  => {
         # SQLite ignores data types aside from INTEGER pks.
         # We just test that they roundtrip sanely.
@@ -112,11 +114,25 @@ my $tester = dbixcsl_common_tests->new(
                   PRIMARY KEY (id1, id2)
                 )
             },
+            q{
+                create table extra_loader_test8 (
+                    id integer primary key
+                )
+            },
+            q{
+                create table extra_loader_test9 (
+                    id integer primary key,
+                    eight_id int,
+                    foreign key (eight_id) 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/ ],
-        count => 11,
+        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,
         run   => sub {
             my ($schema, $monikers, $classes) = @_;
 
@@ -152,6 +168,19 @@ my $tester = dbixcsl_common_tests->new(
 
             isnt $schema->resultset($monikers->{extra_loader_test7})->result_source->column_info('id1')->{is_auto_increment}, 1,
                 q{composite integer PK with non-integer PK doesn't get marked autoinc};
+
+            # test on delete/update fk clause introspection
+            ok ((my $rel_info = $schema->source('ExtraLoaderTest9')->relationship_info('eight')),
+                'got rel info');
+
+            is $rel_info->{attrs}{on_delete}, 'RESTRICT',
+                '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,
+                'DEFERRABLE clause introspected correctly';
         },
     },
 );
@@ -159,5 +188,5 @@ my $tester = dbixcsl_common_tests->new(
 $tester->run_tests();
 
 END {
-    unlink "$tdir/sqlite_test";
+    unlink "$tdir/sqlite_test" unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
 }