view release on metacpan or  search on metacpan

lib/Class/AutoDB/Database.pm  view on Meta::CPAN

package Class::AutoDB::Database;
use vars qw(@ISA @AUTO_ATTRIBUTES @OTHER_ATTRIBUTES %SYNONYMS %DEFAULTS);
use strict;
use DBI;
use Class::AutoClass;
use Hash::AutoHash::Args;
use Class::AutoDB::Registry;
use Class::AutoDB::Cursor;
use Text::Abbrev;
@ISA = qw(Class::AutoClass);

# Mixin for Class::AutoDB. Handles database operations

@AUTO_ATTRIBUTES=qw(object_table
		   _exists);
@OTHER_ATTRIBUTES=qw();
%SYNONYMS=();
%DEFAULTS=(object_table=>'_AutoDB');
Class::AutoClass::declare(__PACKAGE__);

my $GLOBALS=Class::AutoDB::Globals->instance();

# TODO: this is copied from Table.pm.  find a single place for this.
my %TYPES=(string  =>'longtext',
	   integer =>'int',
	   float   =>'double',
	   object  =>'bigint unsigned',);
my @TYPES=keys %TYPES;
my %TYPES_ABBREV=abbrev @TYPES;

# TODO: deal with free-form queries
sub find {
  my $self=shift;
  my $query=$self->parse_query(@_);
  my $cursor=new Class::AutoDB::Cursor(-query=>$query,-dbh=>$self->dbh);
  $cursor;
}
sub get {
  my $self=shift;
  my $cursor=$self->find(@_);
  $cursor->get;
}
sub count {
  my $self=shift;
  my $query=$self->parse_query(@_);
  my $cursor=new Class::AutoDB::Cursor(-query=>$query,-dbh=>$self->dbh);
  $cursor->count;
}
# NG 10-09-15: moved some code around to handle empty query and raw SQL
sub parse_query {
  my $self=shift;
  my $args=new Hash::AutoHash::Args(@_);
  # NG 09-12-19: $autodb needed to remove $value->oid below
  my $autodb=$GLOBALS->autodb;
  my $dbh=$self->dbh;
  my $object_table=$self->object_table;
  my @from=($object_table);	# always need_AutoDB
  # NG 10-09-13: added 'IS NOT NULL' to handle deleted objects
  my @where=qq($object_table.object IS NOT NULL);
  # NG 10-09-15: added support for raw SQL
  my $sql=$args->sql;
  delete $args->{sql};        # so 'sql' will not be confused with a search key!
  push(@where,"$object_table.oid IN ($sql)") if $sql;
  my $limit;			# may be set in 'then' below
  if (%$args) {
    my $name=$args->collection;
    delete $args->{collection};	# so 'collection' will not be confused with a search key!
    my $query=$args->query? $args->query: $args;
    my $collection=$self->registry->collection($name) || $self->throw("Unknown collection $name");
    my $keys=$collection->keys;
    # NG 09-12-18: rewrote to avoid duplicates when selecting from list
    #              and to omit base table when keys are all lists
    my(@base_where,@list_selects);
    while(my($key,$value)=each %$query) {	# create SQL condition for each search key
      if ($key eq '_limit_') { # reserved keyword
	$limit = $value;
	next;
      }
      my $type=$keys->{$key} || $self->throw("Unknown key $key for collection $name");
      if (($type eq 'object' || $type eq 'list(object)') && defined $value) {
	# NG 09-12-19: $value->oid crashes on nonpersistent things. 
	#              change also needed for cleanup of user-object namespace
	# $value=$value->oid;
	# $value=Class::AutoDB::Serialize::obj2oid($value)
	# NG 09-12-22: handle repeated search terms for list(object)
	if ('ARRAY' eq ref $value) {
	  $value=[map {Class::AutoDB::Serialize::obj2oid($_)} @$value];
	} else {
	  $value=Class::AutoDB::Serialize::obj2oid($value)
	}
      }
      my($db_type,$list_type,$table);
      if ($type=~/^list/) {
	# legal to have repeated search terms for list
	my @values='ARRAY' eq ref $value? @$value: ($value);
	($list_type)=$type=~/^list\s*\(\s*(.*)\s*\)/;
	$db_type=$TYPES{$list_type};
        for my $value (@values) {
	  $table=$name."_$key";	# list keys are stored in separate tables
	  my $list_select=qq(SELECT $table.oid FROM $table WHERE ); 
	  if (defined $value) {
	    $value=$dbh->quote($value,$db_type);
	    $list_select.="$table.$key=$value";
	  } else {
	    $list_select.="$table.$key IS NULL";
	  }
	  push(@list_selects,$list_select);