X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FSQLite.pm;h=be60699895e08e19a99d26ae8943e9c2c7208320;hb=c52f11c91a8570f84daf2bfbbf60fa1ef3b32b5b;hp=8edf0bd26b550328c10611bfe45d85441f58312c;hpb=ef73d2ade02190ee6e89138aa52d19f7138272b1;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
index 8edf0bd..be60699 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
@@ -6,7 +6,7 @@ use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
 use mro 'c3';
 use DBIx::Class::Schema::Loader::Table ();
 
-our $VERSION = '0.07027';
+our $VERSION = '0.07042';
 
 =head1 NAME
 
@@ -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,74 @@ 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* "?', 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*)?
+                (?:(?:
+                  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 {
+            # 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;
+            }
+        }
+    }
+
     return \@rels;
 }
 
@@ -163,7 +226,7 @@ sub _table_uniq_info {
         push @uniqs, [ $name => \@cols ];
     }
     $sth->finish;
-    return \@uniqs;
+    return [ sort { $a->[0] cmp $b->[0] } @uniqs ];
 }
 
 sub _tables_list {
@@ -188,6 +251,15 @@ sub _tables_list {
     return $self->_filter_tables(\@tables, $opts);
 }
 
+sub _table_info_matches {
+    my ($self, $table, $info) = @_;
+
+    my $table_schema = $table->schema;
+    $table_schema = 'main' if !defined $table_schema;
+    return $info->{TABLE_SCHEM} eq $table_schema
+        && $info->{TABLE_NAME}  eq $table->name;
+}
+
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
@@ -205,3 +277,4 @@ the same terms as Perl itself.
 =cut
 
 1;
+# vim:et sts=4 sw=4 tw=0: