release 0.07030

[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / SQLite.pm

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
index 8767e45..5331358 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
@@ -2,14 +2,11 @@ package DBIx::Class::Schema::Loader::DBI::SQLite;
 
 use strict;
 use warnings;
-use base qw/
-    DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
-    DBIx::Class::Schema::Loader::DBI
-/;
+use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
 use mro 'c3';
 use DBIx::Class::Schema::Loader::Table ();
 
-our $VERSION = '0.07015';
+our $VERSION = '0.07030';
 
 =head1 NAME
 
@@ -39,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.
@@ -71,15 +68,22 @@ sub _columns_info_for {
     $sth->execute;
     my $cols = $sth->fetchall_hashref('name');
 
+    # copy and case according to preserve_case mode
+    # no need to check for collisions, SQLite does not allow them
+    my %cols;
+    while (my ($col, $info) = each %$cols) {
+        $cols{ $self->_lc($col) } = $info;
+    }
+
     my ($num_pk, $pk_col) = (0);
     # SQLite doesn't give us the info we need to do this nicely :(
     # If there is exactly one column marked PK, and its type is integer,
     # set it is_auto_increment. This isn't 100%, but it's better than the
     # alternatives.
     while (my ($col_name, $info) = each %$result) {
-      if ($cols->{$col_name}{pk}) {
-        $num_pk ++;
-        if (lc($cols->{$col_name}{type}) eq 'integer') {
+      if ($cols{$col_name}{pk}) {
+        $num_pk++;
+        if (lc($cols{$col_name}{type}) eq 'integer') {
           $pk_col = $col_name;
         }
       }
@@ -122,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;
 }
 
@@ -201,3 +242,4 @@ the same terms as Perl itself.
 =cut
 
 1;
+# vim:et sts=4 sw=4 tw=0: