[CDBI] Graph methods with CDBI to retrieve non-adjacent related data

[prev] [thread] [next] [Date index for 2006/01/27]

All,

I've been using Class::DBI for a bit now and came up with what I  
think are a couple of nifty extensions I thought I might share, if  
only to ask if I've simply reinvented someone else's wheel.  The  
first trick I did was to add a method called "as_graph" to my base  
CDBI class so that I could get the whole schema as a Graph::Directed  
object.  It looks essentially like this:

   sub as_graph {
       my $g = Graph::Directed->new;
       for my $table ( represented_tables() ) {
           my $class   = table_name_to_class( $table );
           my $has_a   = $class->meta_info('has_a') || {};
           my %valid   = map { $_, 1 } $class->columns('All');
           my $pk_name = $class->columns('Primary');
           # Check foreign key references.
           if ( %$has_a ) {
               while ( my ( $fk, $fk_info ) = each %$has_a ) {
                   my $fk_class = $fk_info->{'foreign_class'};
                   $g->add_edge( $table, $fk_class->table );
               }
           }
           if ( !$g->has_vertex( $table ) ) {
               $g->add_vertex( $table );
           }
       }
       return $g;
   }

You'll notice that I had to come up with a way to get a listing of  
all the tables, so I hacked in the "represented_tables" method.  Then  
I have a simple algorithm in my "table_name_to_class" for converting  
table names to class names (e.g., table_name =>  
"My::CDBI::Prefix::TableName").

It turns out there are many times when it's nice to have a graph  
representation of your schema, such as when I'm generating my classes  
from my schema[1].  I like to put all the CDBI classes into one file,  
but the class definition needs to be just right to satisfy CDBI's  
"has_a" and "has_many" relationships.  It turns out using  
Graph::Traversal::DFS for a depth-first search is just the way to  
handle this.

Additionally, I've added a method called "get_related" that allows  
any inherited CDBI object to use the graph to query for any related  
object in any table, not just the ones adjacent and defined by  
"has_a" or "has_many."  E.g., say you have a Brewery that makes Beers  
that are served in Pubs, you could ask a Brewery object to return all  
the Pubs in which its Beers are sold like so:

   my @pubs = $brewery->get_related('pub');

The code looks like this:

   sub get_related {
       my $self       = shift;
       my $dest_table = shift or croak 'No destination table';
       my $opts_ref   = shift || {};
       my $this_table = $self->table;
       my $graph      = $self->as_graph;
       if ( !$graph->has_vertex( $dest_table ) ) {
           croak "Invalid destination table ($dest_table)";
       }

       # make edges bidirectional
       my @edges = $graph->edges;
       for my $edge ( @edges ) {
           $graph->add_edge( reverse @$edge );
       }

       my @path = $graph->SP_Dijkstra( $this_table, $dest_table );

       if ( @path ) {
           my $start = shift @path;
           my @data = _uniq(
               grep { $_->table eq $dest_table }
               _extract( $self, \@path )
           );

           if ( @data ) {
               return wantarray ? @data : $data[0];
           }
           else {
               return wantarray ? () : undef;
           }
       }
       else {
           my $this_table = $self->table;
           croak "No path from $this_table to $dest_table";
       }

       return;
   }

This uses a little "_uniq" method (which I hacked from List::MoreUtils):

   sub _uniq {
       my %h;
       map { $h{ $_->id() }++ == 0 ? $_ : () } @_;
   }

And this little recursive "_extract" sub:

   sub _extract {
       my ( $from, $path ) = @_;
       return if !defined $from;
       my $next = shift @$path or return;
       return if !$from->can( $next );
       my @return;
       for my $object ( $from->$next() ) {
           next if !defined $object;
           if ( @$path ) {
               push @return, _extract( $object, $path );
           }
           else {
               push @return, $object;
           };
       }
       return @return;
   }

I'm very interested to see if anyone would comment on this because  
I'm not very confident that it's as well-written as it could be.  I  
had troubles initially when there wasn't data along the path to get  
to the destination table, so it would return at whatever furthest  
object it would reach.

Additionally, I'm trying to figure out a way for the "get_related" to  
sort the found objects, so I'd love to hear any suggestions there.

I hope some of you find this helpful or interesting.

Humbly,

ky

[1] -  Using a template and SQL::Translator.  I'm happy to post that  
code if anyone is interested in autogenerating code from schemas.

_______________________________________________
ClassDBI mailing list
ClassDBI@xxxxx.xxxxxxxxxxxxxxxx.xxx
http://lists.digitalcraftsmen.net/mailman/listinfo/classdbi