DBIx::Schema - An SQL Abstration layer for working with whole schemas

 use Schema;
 my $schema = DBIx::Schema->new({db=>'my_db',user=>'db_user',password=>'gigglesnark'});

 my $schema = DBIx::Schema->new($my_dbix_abstract_handle);

 $sth = $schema->select({table=>'product', where=>{'product.id'=>['<',6]}});
 while (my $row = $sth->fetchrow()) {
   print $row->{'name'}."\n";
   print $row->color->{'name'}."\n";
   print $row->{'price'}."\n";
   print $row->{'fish'}."\n";
 }

 # I already have a $schema object defined.
 # I'll make a simple statement handle.

 $sth = $schema->select({table=>'product', where=>{'product.price'=>['<',6]}});
 # OK, $sth is now primed to return all products costing less than
 # $6.00.

 while (my $product_row = $sth->fetchrow) {
   print "I am on product ".$product_row->{'name'}."\n";
   # Let's say I have a many-to-many relationship in my schema that
   # allows products to exist in any number of categories. I want to
   # display all categories to which this product belongs. The current
   # statement handle doesn't know or care about categories, so it's
   # time to pull out a new one.
   if ($product_row->category->rows) {
     print "It is in the following categories:\n";
     while (my $cat_row = $product_row->category->fetchrow) {
       print $cat_row->{'name'}."\n";
     }
   } else {
     print "It is not in any category.\n";
 }

package DBIx::Schema;
use strict;
use DBIx::Abstract;
use DBIx::Datadict;

use vars qw($VERSION);

$VERSION = '0.07';

sub connect {
    # This is just an alias for new
    my $self = shift->new(@_);
    return $self;
}

sub version {
    return $VERSION;
}

sub new {
    # Create a new object an initialize it
    my $class = shift; $class = ref($class) || $class;
    my $self = {};
    bless($self, $class);
    if ($self->initialize(@_)) { 
        return $self; 
    } else { 
        return 0;
    }
}

sub initialize {
    # Initialize our new object.  Our first parameter should be either
    # a DBIx::Abstract object or a DBIx::Abstract connect string.  Our
    # second parameter is a datadict object.  If we aren't given one
    # then we'll create one using our database object.

    my $self = shift;
    if ( (ref($_[0]) eq 'DBIx::Abstract') || (ref($_[0]) eq 'SQL::DBI') ) {
        # We've been passed a legal dbh object
        $self->{'dbh'} = $_[0];
    } else {
        # This ought to be a datasource connect hashref, then
        $self->{'dbh'} = DBIx::Abstract->connect($_[0]);
    }
    if ( (ref($_[1]) eq 'DBIx::Datadict') ) {
        # We've been passed a legal datadict object
        $self->{'dd'} = $_[1];
    } else {
        $self->{'dd'} = DBIx::Datadict->new({dbh=>$self->{'dbh'},preload=>1});
    }
    # Define instance variables as hashrefs or arrayrefs
    $self->{'field_names'} = {};
    $self->{'table_relations'} = {};
    $self->{'field_table_names'} = {};

}

sub select {
    # This is the primary method to start of using this module.
    my $self = shift;
    my ($args) = @_;
    $self->error("The 'select' method requires a single hashref as an argument.") unless ref($args) eq 'HASH';

    # The limits for the query.  Same format as DBIx::Abstract
    my $where = $$args{'where'};

    # Clear out our instance variables from prior runs
    $self->{'visited_tables'} = {};
    $self->{'parent_links'} = [];
    $self->{'child_links'} = [];
    $self->{'seen_tables'} = {};
    $self->{'needed_tables'} = {};

    # Build list of additional required tables.  This should only be needed
    # if tables are being used in a way invisible to Schema, like if the
    # where is a scalar.
    my @tables;
    if (ref($$args{'tables'}) eq 'ARRAY') {
        @tables = @{$$args{'tables'}};
    } elsif (exists($$args{'tables'}) and !ref($$args{'tables'})) {
        @tables = split(/\s*,\s*/,$$args{'tables'});
    }

    # Set our key_table.  The term key_table is an internal one and probably
    # shouldn't be used by programs using this library.
    my $key_table = $$args{'key_table'} || $$args{'table'} || $tables[0];

    # If key_table still isn't set by this point, we can't go on.
    $self->error("Sorry, can't perform a schema select without a key table.  Please pass a 'table' or 'tables' argument.") unless $key_table;

    $self->{'key_table'} = $key_table;

    # These add all the tables that we'll be needing
    $self->require_tables_from_where($where) if $where;
    $self->require_tables_from_order($$args{'order'}) if exists($$args{'order'});
    $self->require_tables($key_table,@tables);

    # It shouldn't be possible to get to this stage without required tables.
    $self->error("Ack, I don't have any required tables, can't perform schema crawl, glub glub glub.") unless keys(%{$self->{'needed_tables'}});

    # Swim the schema till we find all required tables.
    # A chaaaange. Now we do it once for every needed table.
    undef($self->{'visited_tables'});
    foreach my $sought_table (keys(%{$self->{'needed_tables'}})) {
        $self->{'sought_table'} = $sought_table;
        undef($self->{'contestants'});
        $self->schema_crawl($key_table, 0);
        # Stuff here to choose a winner and put it somehwere.
        my $shortest_distance;
        my $winning_path;
        my $equal_distance_warning = 0;
        my @equal_distance_contestants = ();
        foreach my $contestant (@{$self->{'contestants'}}) {
            if ( (not(defined($shortest_distance))) or ($$contestant{'distance'} < $shortest_distance) ) {
                $shortest_distance = $$contestant{'distance'};
                $equal_distance_warning = 0;
                @equal_distance_contestants = ($contestant);
                $winning_path = $contestant;
            } elsif ( (defined($shortest_distance)) and ($shortest_distance == $$contestant{'distance'}) ) {
                $equal_distance_warning = 1;
                push (@equal_distance_contestants, $contestant);
            }
        }
        if ($equal_distance_warning) {
            # Uh oh! We have two contestants of the same length which
            # are both the shortest of the bunch.
            warn "***Equal distance warning from $key_table to $sought_table!\n";
#            foreach my $contestant (@equal_distance_contestants) {
#                warn "---\n";
#                warn Dumper($contestant);
#            }
#            warn "---\n";
        }
        my @tables = keys(%{$$winning_path{'visited_tables'}});
        # AND in the parents and kids this winner found.
        foreach (qw(parent child)) {
            push (@{$self->{"${_}_links"}}, @{$$winning_path{"${_}_links"}});
        }
        # AND in the tables this winner visited.
        @{$self->{'visited_tables'}}{keys(%{$$winning_path{'visited_tables'}})} = 1;
    }

    # Create our list of fields.
    $self->{'fields'} = $self->field_list_generator($key_table);

    my $query = $self->generate_query($args);

    # We now have enough information to do a select.
    my $dbh = $self->{'dbh'}->clone;
    $dbh->select($query);
    # Prepare a new statment handle object. This is our return value.
    my $sth = {};
    bless ($sth, 'Statement');
    $sth->{' _dbh'} = $dbh;
    $sth->{' _dd'} = $self->{'dd'};
    $sth->{' _key_table'} = $key_table;
    $sth->{' _schema'} = {%$self};
    $sth->{' _original_args'} = $args;
    $sth->fetchrow();
    # Add it to myself.
    $self->{'sths'}{$sth} = $sth;

    return $sth;
    # The database handle is now ready for fetchrowing!
}

sub count {
    # This is the primary method to start of using this module.
    my $self = shift;
    my ($args) = @_;
    $self->error("The 'select' method requires a single hashref as an argument.") unless ref($args) eq 'HASH';

    # The limits for the query.  Same format as DBIx::Abstract
    my $where = $$args{'where'};

    # Clear out our instance variables from prior runs
    $self->{'visited_tables'} = {};
    $self->{'parent_links'} = [];
    $self->{'child_links'} = [];
    $self->{'seen_tables'} = {};
    $self->{'needed_tables'} = {};

    # Build list of additional required tables.  This should only be needed
    # if tables are being used in a way invisible to Schema, like if the
    # where is a scalar.
    my @tables;
    if (ref($$args{'tables'}) eq 'ARRAY') {
        @tables = @{$$args{'tables'}};
    } elsif (exists($$args{'tables'}) and !ref($$args{'tables'})) {
        @tables = split(/\s*,\s*/,$$args{'tables'});
    }

    # Set our key_table.  The term key_table is an internal one and probably
    # shouldn't be used by programs using this library.
    my $key_table = $$args{'key_table'} || $$args{'table'} || $tables[0];

    # If key_table still isn't set by this point, we can't go on.
    $self->error("Sorry, can't perform a schema select without a key table.  Please pass a 'table' or 'tables' argument.") unless $key_table;

    $self->{'key_table'} = $key_table;

    # These add all the tables that we'll be needing
    $self->require_tables_from_where($where) if $where;
    $self->require_tables_from_order($$args{'order'}) if exists($$args{'order'});
    $self->require_tables($key_table,@tables);

    # It shouldn't be possible to get to this stage without required tables.
    $self->error("Ack, I don't have any required tables, can't perform schema crawl, glub glub glub.") unless keys(%{$self->{'needed_tables'}});

    # Swim the schema till we find all required tables.
    $self->schema_crawl($key_table, 0);

    # Create our list of fields.
    $self->{'fields'} = 'count(*)';

    my $query = $self->generate_query($args);
    delete($$query{'group'});

    # We now have enough information to do a select.
    my $dbh = $self->{'dbh'}->clone;
    $dbh->select($query);

    return ($dbh->fetchrow_array())[0];
}

sub error {
    # A fatal error has occurred. Report something, then throw an exception.
    my $self = shift;
    my ($message) = @_;
    # Very simple for now.
    die "DBIx::Schema error: $message \n";
}

sub require_tables_from_where {
    # Because DBIx::Abstract's 'where' clauses can be so joyously recursive,
    # we must crawl though them similarly to extract all the table to which
    # they might refer.
    my $self = shift;
    my ($where_piece, $depth) = @_;
    $depth ||= 0;
    if ($depth > 20) {
        $self->warning("Yipes, overdeep recursion while parsing 'where'. Strange behavior may result.");
        return;
    }
    if (ref($where_piece) eq 'HASH') {
        $self->require_tables(keys(%$where_piece));
    } elsif (ref($where_piece) eq 'ARRAY') {
        foreach (@$where_piece) {
            $self->require_tables_from_where($_, $depth++) if ref($_);
            # If it's not a ref, it's just a conjunction string, like 'AND'.
        }
    } else {
        $self->warning("Unable to parse a 'where' piece: $where_piece .");
    }
}

sub warning {
    # Report a warning.
    my $self = shift;
    my ($message) = @_;
    # Very simple for now.
    warn "DBIx::Schema warning: $message \n";
}

sub require_tables {
    # Take a list of tables and mark them as needed.
    my $self = shift;
    my(@tables) = @_;
    foreach my $table (@tables) {
        # Strip off any field part of this
        $table =~ s/\.(.*)//g;
        $self->{'needed_tables'}{$table} = 0; # Will be 1 when found.
    }
}

sub require_tables_from_order {
    # Find the tables in the order and require them.
    my $self = shift;
    my ($order) = @_;
    if (ref($order) eq 'ARRAY') {
        $self->require_tables(@$order);
    } elsif (!ref($order)) {
        $self->require_tables(split(/\s*,\s*/,$order));
    } else {
        $self->warning("Unable to parse a 'order': $order");
    }
}

sub schema_crawl {
    # A recursive method for building a path between a bunvh of tables.
    # The passed-in parameter is the table it's sitting on now.
    my $self = shift;
    my ($table, $depth, $v_relations, $v_tables, $relation_id, $winners) = @_;
    
    $v_relations ||= [];
    push(@$v_relations, $relation_id) if defined($relation_id);

    $v_tables ||= {};

    # We will keep a list of winninginging paths.
    # Why not make this an object thing? Grah. Grah, I say!
    # Consistiency. I REALLY WANT TO MAKE THIS MORE OO! OOooOOOooOOooOOO!

    $winners ||= [];

    # Make sure we're not spiraling down too deep
    $depth++;
    if ($depth > 25) {
        $self->warning("Overdeep recursion with $table!!");
        return 0;
    }

    # Mark this table as visited.
    $$v_tables{$table} = 1;

    # Check if the current table matches that which we seek.
    if ($self->{'sought_table'} eq $table) {
        # Why yes, it does!
        # We will add this to the list of winning paths.
        my %contestant;         # Not a winner yet. ;)
        # Drop on some debuggin info
        $contestant{'sought_table'} = $table;
        # Initialize this new contestant
        foreach (qw(parent child)) {
            $contestant{"${_}_links"} = [];
        }
        foreach my $relation (@$v_relations) {
            foreach (qw(parent child)) {
                push (@{$contestant{"${_}_links"}}, $$relation{$_});
            }
        }
        # Mark how far it traveled to get here...
        $contestant{'distance'} = $depth;
        # ...and what tables it has visited.
        @{$contestant{'visited_tables'}}{keys(%$v_tables)} = 1;
        # OK, store this contestant.
        push (@{$self->{'contestants'}}, \%contestant);

         # WE NO LONGER NEED TO
#        # Check to see if we're done
#        # I wonder if there's a faster way to do this
#
#        my $all_found = 1;
#        foreach (values(%{$self->{'needed_tables'}})) {
#            if ($_ == 0) {
#                $all_found = 0;
#                last;
#            }
#        }
#        if ($all_found) {       # Yay, we are done
#            return 1;
#        }
    }
    # Gather up links.
    
    
    my $dd = $self->{'dd'};
    my @my_relations;
    
    # Skip all this stuff if we've gone through this already.
    if (my $my_relations = $self->{'table_relations'}{$table}) {
        # OK, it's been cached. Use that copy.
        @my_relations = @$my_relations;
    } else {
        my $table_info = $dd->lookup_table($table);
        foreach (values(%{$$table_info{'parent'}})) {
            if ($dd->lookup_field($$_{'parent'})->{'md_table_id'} == $$table_info{'id'}) {
                push(@my_relations, [{parent=>$$_{'child'}, child=>$$_{'parent'}}, $$_{'child'}]);
            } else {
                push(@my_relations, [{parent=>$$_{'parent'}, child=>$$_{'child'}}, $$_{'parent'}]);
            }
        }
        # Cache relations.
        $self->{'table_relations'}{$table} = \@my_relations;
    }
    # Loop through this table's links.
    unless (@my_relations) {
        return;
    }  
    
    foreach (@my_relations) {
        my ($relation_id, $field_id) = @$_;
        # See which table this is from
        my $table;
        unless ($table = $self->{'field_table_names'}{$field_id}) {
            $table = $self->{'dd'}->lookup_table($self->{'dd'}->lookup_field($field_id)->{'md_table_id'})->{'name'};
            $self->{'field_table_names'}{$field_id} = $table;
        }
        if (exists($$v_tables{$table})) {
            next;
        }
        # Ah, a strange table. Let's dive down a level.
        # First, gotta dereference and then re-reference things, to prevent
        # sharing. This is egregiously dumb and uses too much memory, and
        # I'll need to think of something better soon.
        $self->schema_crawl($table, $depth, [@$v_relations], {%$v_tables}, $relation_id);
    }
}  

sub field_list_generator {
    # Convert table list (stored in selectables) into a list of all the
    # fields to select with
    my $self = shift;
    my(@tables) = @_;
    my $output = [];
    foreach my $table (@tables) {
        my $table_info = $self->{'dd'}->lookup_table($table);
        if ($table_info) {
            foreach (keys(%{$table_info->{'field'}})) {
                push(@$output, "$table.$_ AS '$table.$_'");
            }
        } else {
            $self->error("Unknown table: $table");
        }
    }
    $self->error("All of your tables are bogus!") unless @$output;
    return $output;
}

sub generate_query {
    # Generate a query for DBIx::Abstract
    my $self = shift;
    my ($args) = @_;
    my $parents = $self->{'parent_links'};
    my $children = $self->{'child_links'};
    my $joins;
    my $query;                    # return value (hashref)

    if ($parents) {
        for (my $i=0;$i<scalar(@$parents);$i++) {
            my $parent_name = $self->field_name($$parents[$i]);
            my $child_name = $self->field_name($$children[$i]);
            push (@$joins, "$parent_name = $child_name")  if $parent_name and $child_name;
        }
    }

    # These three values we always need:
    $query = {
              fields=>$self->{'fields'},
              tables=>[keys(%{$self->{'visited_tables'}})],
              'join'=>$joins,
              };

    $$args{'group'} ||= [];
    if (!ref($$args{'group'})) {
        $$args{'group'} = [split(/\s*,\s*/,$$args{'group'})];
    } elsif (ref($$args{'group'}) ne 'ARRAY') {
    	$self->warning("Unparsable group ARRAY");
    	$$args{'group'} = [];
    }
    my @group = @{$$args{'group'}};
    push(@group,$self->{'key_table'}.'.id');

    # Now take care of optional, $args-based pieces:
    $$query{'where'} = $$args{'where'} if defined($$args{'where'});
    $$query{'order'} = $$args{'order'} if defined($$args{'order'});
    $$query{'extra'} = $$args{'limit'} if defined($$args{'limit'});
    $$query{'group'} = \@group;

    # Handle extra fields
    if (defined($$args{'fields'})) {
        if (ref($$args{'fields'}) eq 'ARRAY') {
            push(@{$$query{'fields'}},@{$$args{'fields'}});
        } elsif (!ref($$args{'fields'})) {
            $$query{'fields'} = join(', ',@{$$query{'fields'}},$$args{'fields'});
        }
    }

    return $query;
}

sub field_name {
    # Returns the name of a given field id. Uses a cache.
    my $self = shift;
    my ($field_id) = @_;
    my $field_names = $self->{'field_names'};
    unless (defined($$field_names{$field_id})) {
        my $field = $self->{'dd'}->lookup_field($field_id);
        my $table = $self->{'dd'}->lookup_table($$field{'md_table_id'});
        $$field_names{$field_id} = "$$table{'name'}.$$field{'name'}";
    }
    return $$field_names{$field_id};
}

sub flush_cache {
    # Nix the object's internal caches.
    my $self = shift;
    $self->{'table_relations'} = {};
    $self->{'field_table_names'} = {};
    $self->{'field_names'} = {};
}

sub DESTROY {
    # Make sure all surviving statement handles are slain, and
    # avoid the yuckyness of circular references.
    my $self = shift;
    foreach my $possession (qw(sths dbhs)) {
        foreach (values(%{$self->{$possession}})) {
            %$_ = ();
        }
    }
}



#####################################################################

package Row;

use vars qw($AUTOLOAD);

sub AUTOLOAD {
    my $self = shift;
    my $name = $AUTOLOAD;
    $name =~ s/.*://;             # strip pacakge name

    return if $name eq 'DESTROY';   # We have no destructor

    my $new_sth;
    if ($self->{' _sub_sth'} && $self->{' _sub_sth'}{' _key_table'} eq $name) {
        $new_sth = $self->{' _sub_sth'};
    } else {
        my $sth = $self->{' _sth'};
        my $args = {%{$sth->{' _original_args'}}};
        my $key_table = $sth->{' _key_table'};
        # Gotta deref & reref the present 'where' to avoid circular reference
        # in the new 'where'...
        if ($$args{'where'}) {
            $$args{'where'} = [$$args{'where'}, 'AND', {"$key_table.id"=>$self->{'id'}}];
        } else {
            $$args{'where'} = {"$key_table.id"=>$self->{'id'}};
        }
        $$args{'key_table'} = $name;
        $$args{'fields'} = ["$name.*"];
        #    my $schema = $sth->{'schema'};
        my $schema = DBIx::Schema->new($sth->{' _dbh'}->clone(),$sth->{' _dd'});
        # Hmm... I think limits are causing a problem
        delete($$args{'limit'});
        # Store this old schema on the old one
        $sth->{' _schema'}->{'dbhs'} = $schema;

        $new_sth = $schema->select($args);
        $self->{' _sub_sth'} = $new_sth;
    }

    return $new_sth;
}

sub sth {
    my $self = shift;
    # Returns the statement handle from which this row was created.
    return bless($self->{' _sth'}, 'Statement');
}

#####################################################################

package Statement;

sub fetchrow {
    # The other major user-invocable method.
    # Like the select method, it's a DBIx::Abstract wrapper.
    my $self = shift;
    my $dbh = $self->{' _dbh'};
    my $last_row_obj = $self->{' _current_row_obj'};
    if (ref($last_row_obj) and not %$last_row_obj) {
        # We were given an empty hashref... this is the last iteration...
        return undef;
    }
    $last_row_obj ||= {};
    if (my $row = $dbh->fetchrow_hashref()) {
        # Fill me up...
        $self->fill_self($row);
        # Set a bunch of instance variables.
        $self->{' _current_row'} = $row;
        my $row_obj = {};
        bless ($row_obj, 'Row');
        # Stick a copy of the schema object onto the row object.
        # Note the use of somewhat bogus private-variable naming scheme.
        $row_obj->{' _sth'} = {%$self};
        $self->fill_row($row, $row_obj, $self->{' _key_table'});
        # Boy, this is sloppy. Still deciding what to do with these objects.
        $self->{' _current_row_obj'} = $row_obj;
        return $last_row_obj;
    } else {
        # Got nuthin.
        if (defined($last_row_obj)) {
            $self->{' _current_row_obj'} = {};
            return $last_row_obj;
        } else {
            return undef;
        }
    }
}

sub key_table {
    # Return a string describing this handle's key table.
    my $self = shift;
    return $self->{' _key_table'};
}

sub rows {
    # Returns result of the DBIx::Abstract method of the same name.
    my $self = shift;
    return $self->{' _dbh'}->rows();
}

sub fill_row {
    # Fills out a row object's instance variables with various goodies.
    my $self = shift;
    my ($row, $row_obj, $key_table) = @_;
    # I represent this data very schizophrenically whilst I try to ascertain
    # the best way to represent it. Hee.
    foreach (keys(%$row)) {
        my ($table, $field) = split(/\./);
        $table ||='';
        $field ||= '';
        if (defined($table) and defined($key_table) and $table eq $key_table) {
            $row_obj->{$field} = $$row{$_};
            $row_obj->{"$table.$field"} = $$row{$_};
        } else {
            $row_obj->{"$table.$field"} = $$row{$_};
        }
    }
}  

sub fill_self {
    # Like fill_row, except it paints all over itself instead.
    my $self = shift;
    my ($row) = @_;
    my $key_table = $self->{' _key_table'};
    foreach (keys(%$row)) {
        my ($table, $field) = split(/\./);
        $table ||='';
        $field ||= '';
        if ($table eq $key_table) {
            $self->{$field} = $$row{$_};
            $self->{"$table.$field"} = $$row{$_};
        } else {
            $self->{"$table.$field"} = $$row{$_};
        }
    }
}  

1;