From: Rafael Kitover <rkitover@cpan.org>
Date: Wed, 17 Oct 2012 16:30:46 +0000 (-0400)
Subject: WIP
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=refs%2Fheads%2Ftopic%2Ffb_fks;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

WIP
---

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
index a1a8a61..7288c3d 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
@@ -25,7 +25,7 @@ See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
 =head1 COLUMN NAME CASE ISSUES
 
 By default column names from unquoted DDL will be generated in lowercase, for
-consistency with other backends. 
+consistency with other backends.
 
 Set the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
 to true if you would like to have column names in the internal case, which is
@@ -93,7 +93,7 @@ EOF
 sub _table_fk_info {
     my ($self, $table) = @_;
 
-    my ($local_cols, $remote_cols, $remote_table, @rels);
+    my ($local_cols, $remote_cols, $remote_table, $attrs, @rels);
     my $sth = $self->dbh->prepare(<<'EOF');
 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
 FROM rdb$relation_constraints rc
@@ -110,7 +110,9 @@ EOF
         s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
 
         push @{$local_cols->{$fk}},  $self->_lc($local_col);
+
         push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
+
         $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new(
             loader => $self,
             name   => $remote_tab,
@@ -121,6 +123,36 @@ EOF
         );
     }
 
+    local $self->dbh->{LongReadLen} = 100_000;
+    local $self->dbh->{LongTruncOk} = 1;
+
+    my %RULE_FOR = (
+        4 => 'on_update',
+        6 => 'on_delete',
+    );
+
+    $sth = $self->dbh->prepare_cached(<<'EOF');
+select rdb$trigger_blr, rdb$trigger_type
+from rdb$triggers
+where rdb$trigger_type in (4,6)
+    and rdb$system_flag > 0
+    and rdb$relation_name = ?
+EOF
+
+    foreach my $fk (keys %$remote_table) {
+        my $uk_table = $remote_table->{$fk};
+
+        $sth->execute($uk_table);
+
+        while (my ($blr, $type) = $sth->fetchrow_array) {
+            $type = $RULE_FOR{$type};
+
+            print STDERR "GOT $type:\n";
+            use Data::Dumper;
+            print STDERR Dumper($blr), "\n";
+        }
+    }
+
     foreach my $fk (keys %$remote_table) {
         push @rels, {
             local_columns => $local_cols->{$fk},
diff --git a/t/10_09firebird_common.t b/t/10_09firebird_common.t
index 39fc849..fa13184 100644
--- a/t/10_09firebird_common.t
+++ b/t/10_09firebird_common.t
@@ -127,11 +127,74 @@ my $tester = dbixcsl_common_tests->new(
                       => { data_type => 'blob sub_type text character set unicode_fss' },
     },
     extra => {
-        count  => 9,
+        create => [
+            q{
+                create table firebird_loader_test9 (
+                    id integer not null primary key
+                )
+            },
+            q{
+                create table firebird_loader_test10 (
+                    id integer not null primary key,
+                    nine_id integer,
+                    foreign key (nine_id) references firebird_loader_test9(id)
+                        on delete no action on update no action
+                )
+            },
+            q{
+                create table firebird_loader_test11 (
+                    id integer not null primary key,
+                    nine_id integer,
+                    foreign key (nine_id) references firebird_loader_test9(id)
+                        on delete cascade on update cascade
+                )
+            },
+            q{
+                create table firebird_loader_test12 (
+                    id integer not null primary key,
+                    nine_id integer,
+                    foreign key (nine_id) references firebird_loader_test9(id)
+                        on delete set default on update set default
+                )
+            },
+            q{
+                create table firebird_loader_test13 (
+                    id integer not null primary key,
+                    nine_id integer,
+                    foreign key (nine_id) references firebird_loader_test9(id)
+                        on delete set null on update set null
+                )
+            },
+        ],
+        drop  => [ qw/firebird_loader_test9 firebird_loader_test10 firebird_loader_test11
+                      firebird_loader_test12 firebird_loader_test13/ ],
+        count  => 4 * 4 + 9,
         run    => sub {
             $schema = shift;
             my ($monikers, $classes, $self) = @_;
 
+            my %fk_tests = (
+                10 => 'NO ACTION',
+                11 => 'CASCADE',
+                12 => 'SET DEFAULT',
+                13 => 'SET NULL',
+            );
+
+            # test on delete/update fk clause introspection
+            foreach my $tbl_num (qw/10 11 12 13/) {
+                ok ((my $rel_info = $schema->source("FirebirdLoaderTest${tbl_num}")->relationship_info('nine')),
+                    'got rel info');
+
+                is $rel_info->{attrs}{on_delete}, $fk_tests{$tbl_num},
+                    'ON DELETE clause introspected correctly';
+
+                is $rel_info->{attrs}{on_update}, $fk_tests{$tbl_num},
+                    'ON UPDATE clause introspected correctly';
+
+                is $rel_info->{attrs}{is_deferrable}, 1,
+                    'is_deferrable defaults to 1';
+            }
+
             cleanup_extra();
 
             my $dbh = $schema->storage->dbh;