Recursively traversing DBIx::Class relationships

Question

Which is the quickest way to get the list of tables that have foreign key dependencies, both direct and indirect, to DBIx::Class subclass foo? I have a MySQL database based on a DBIx::Class::Schema. Can DBIx::Class be used directly, or can SQL::Translator help by generating a digraph?

Given the following classes:

package MySchema::Foo;

...

package MySchema::Bar;

__PACKAGE__->belongs_to('foo', 'MySchema::Foo');

package MySchema::Baz;

__PACKAGE__->belongs_to('bar', 'MySchema::Bar');

For the input Foo, the output should be [ Bar, Baz ].

Answer 1

Cooked this with DBIx::Class's ::Schema and ::ResultSource. First builds a hash(ref) of referencing classes and then traverses it:

#!/usr/bin/perl

use strict;
use warnings;
use MySchema;
use Set::Scalar;

# add_sfk: adds a foreign key reference from $src to $dst
sub add_sfk {
    my ( $sfks, $src, $dst ) = @_;

    $sfks->{$src} ||= Set::Scalar->new;
    $sfks->{$src}->insert($dst);
}

my $conn = MySchema->connect(...);

my $scname = ref $conn;
my $sfks = {}; # the foreign key hash

# now we build the hash from sources relationships
foreach my $sname ($conn->sources) {
    my $s = $conn->source($sname);
    my $cname = $conn->class($sname);
    foreach my $rname ($s->relationships) {
        my $rel = $s->relationship_info($rname);
        my @conds = keys %{ $rel->{cond} };
        next if scalar @conds > 1; # reckon this should never happen
        (my $stgt = $rel->{source}) =~ s/^${scname}:://;
        foreach my $ckey (@conds) {
            add_sfk($sfks, $stgt, $sname) if ('foreign.id' eq $ckey); # belongs_to
            add_sfk($sfks, $sname, $stgt) if ('self.id' eq $rel->{cond}->{$ckey}); # has_(one|many)
        }
    }
}

my $sname = shift or die("No class given as input");

# time to traverse our hash to include indirect relationships
my $deps = $sfks->{$sname};
my $lastdeps = $deps;
my $newdeps;
do {
    $newdeps = Set::Scalar->new;
    foreach my $sn ($lastdeps->elements) {
        my $sdeps = $sfks->{$sn} or next;
        if ($sdeps -= $lastdeps) {
            $newdeps += $sdeps;
        }
    }
    $deps += $lastdeps;
    $lastdeps = $newdeps;
} while ($newdeps);

print "Dependencies of $sname:\n" . join("\n", map { $conn->source($_)->from } @$deps);