#
# DBUtils.pm
#   a module for useful database utilities
#
package Bio::Genex::DBUtils;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $CGIURL $DEBUG %TABLES $NO_FETCH_ALL $NO_FETCH_DISTINCT %EXPORT_TAGS);
use Carp;

use DBI;
use CGI;
use Bio::Genex;

require Exporter;

@ISA = qw(Exporter);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT_OK = qw(assert_table_defined 
		assert_dbh
		create_insert_sql
		create_update_sql
		create_select_sql
		check_password
		fetch_user_al_ids
		fetch_last_id
		fetch_es_ids
		fetch_es_species
		fetch_am_ids
		fetch_fkey_list
		fetch_spot_data
		output_spot_data
		lookup_usf_id 
		lookup_contact_id
		lookup_id 
		lookup_software_id 
		lookup_experiment_id 
		lookup_species_id);


%EXPORT_TAGS = (CREATE => [qw(
			      create_insert_sql
			      create_update_sql
			      create_select_sql
			     )],
		ASSERT => [qw(assert_table_defined 
			      assert_dbh
			     )],
		FETCH => [qw(fetch_user_al_ids
			     fetch_last_id
			     fetch_es_ids
			     fetch_es_species
			     fetch_am_ids
			     fetch_fkey_list
			     fetch_spot_data
			    )],
	       );
Exporter::export_ok_tags('CREATE', 'ASSERT', 'FETCH');

$VERSION = '0.02';
$DEBUG = 0;
$NO_FETCH_ALL = 0;
$NO_FETCH_DISTINCT = 0;

$CGIURL = '%%GENEX_CGI_URL%%';

=head1 NAME

DBUtils - a module for useful Database utilities 

=head1 SYNOPSIS

  use DBUtils;

  assert_table_defined($dbh,$table_name);

  assert_dbh($dbh);

  $id = fetch_last_id($dbh,$table_name);

  $sql_string = create_insert_sql($dbh,$table_name,@column_names);

  $sql_string = create_update_sql($dbh,$table_name,
                                  SET=>$array_ref,WHERE=>$string);

  $sql_string = create_select_sql($dbh,
                                  COLUMNS=>$array_ref,
				  FROM=>$array_ref,
				  WHERE=>$where_string,
				  DISTINCT=>$bool,
                                  LIMIT=>$bool,
                                 );

  $species = fetch_es_species($es_pk);

  @ids = fetch_es_ids();

  @ids = fetch_user_al_ids($us_fk);

  @ids = fetch_am_ids($experiment_set_pk, 
                      @array_measurement_types);

  $array_ref = fetch_fkey_list($dbh,
                               $table_name,
                               $column_name,
                               $pkey,
                               $rec_level);

  $exp_set = fetch_spot_data($es_pk,@am_types);

  output_spot_data($file_handle,
                   $experiment_set_pk,
                   @array_measurement_types);

  $id = lookup_id($dbh,$table,$attribute,$value,$approx);

  $id = lookup_species_id($dbh,$species_name,$approx);

  $id = lookup_usf_id($dbh,$usf_name,$approx);

  $id = lookup_contact_id($dbh,$contact_name,$approx);

  $id = lookup_software_id($dbh,$software_name,$approx);


=head1 DESCRIPTION

Helper functions for achieving common DB tasks with a GeneX DB.

=head1 FUNCTIONS

=over 4

=cut

# Preloaded methods go here.
#----------------------------------------------------------------------
#

=item create_update_sql($dbh,TABLE=>$table,SET=>$hash_ref,WHERE=>$string)

Returns an SQL string valid for the current DBMS. It is up to the
caller whether to use DBI placeholders or not, they will not be
generated by the subroutine.


=cut


sub create_update_sql {
  my ($dbh,%args) = @_;
  assert_dbh($dbh);

  # check the TABLE argument
  my $curr_table = $args{TABLE};
  if (ref($curr_table)) {
    die "Bio::Genex::DBUtiles::create_update_sql: expected table name, got: $curr_table\n";
  }
  assert_table_defined($dbh,$curr_table);

  # check the SET argument
  die "Bio::Genex::DBUtils::create_update_sql: SET argument not provided"
    unless exists $args{SET};
  die "Bio::Genex::DBUtils::create_update_sql: SET argument not a hash ref"
    unless ref($args{SET}) eq 'HASH';

  if ($dbh->dbms() eq 'Pg') {
    my @set;
    my %set = %{$args{SET}};
    foreach my $col (keys %set) {
      push(@set, "$col=" . $dbh->quote($set{$col}));
    }
    my $set_string = join(',', @set);
    my $sql = "UPDATE $curr_table SET $set_string";
    $sql .= " WHERE $args{WHERE}" if exists $args{WHERE};
  } else {
    carp "Bio::Genex::DBUtils::create_update_sql: Driver ", $dbh->dbms(), " not implemented";
  }
}

#----------------------------------------------------------------------


=item create_insert_sql($dbh,$table,\@column_names)

=item create_insert_sql($dbh,$table,\%col_val_pairs)

There are two methods of invoking create_insert_sql. If invoked with
only an array reference of column names, create_insert_sql will return
an SQL string with placeholders for use by the DBI C<prepare()> and
C<exectute()> methods. In this case the C<\@columen_name> reference
contains the names and order of the columns we plan to insert data in
C<$table>.

If invoked with a hash reference of column name/value pairs,
create_insert_sql will return a final SQL string that can be used by
DBI C<do()>.

=cut


sub create_insert_sql {
  my ($dbh,$curr_table,$namelist_ref) = @_;
  assert_dbh($dbh);
  if (ref($curr_table)) {
    die "Bio::Genex::DBUtiles::create_insert_sql: expected table name, got: $curr_table\n";
  }
  assert_table_defined($dbh,$curr_table);
  carp "Bio::Genex::DBUtils::create_insert_sql: Driver ", $dbh->dbms(), " not implemented"
    unless $dbh->dbms() eq 'Pg';

  if (ref($namelist_ref) eq 'ARRAY') {
    if ($dbh->dbms() eq 'Pg') {
      # create a list of the column names
      my $keys_string = join(",", @{$namelist_ref});
    
      # make a question mark string:
      #   1) calculate the correct number of '?'s using scalar()
      #   2) make a list of the right number of ?'s using split()
      #   3) insert commas betweent the ?'s using join()
      my $questions = join (',', split('', '?' x scalar(@{$namelist_ref})));
    
      return "INSERT INTO $curr_table ($keys_string) VALUES ($questions)";
    } 
  } elsif (ref($namelist_ref) eq 'HASH') {
    if ($dbh->dbms() eq 'Pg') {
      # create a list of the column names
      my $keys_string = join(",", keys %{$namelist_ref});

      # we use DBI::quote to handle the quoting for us
      my $values_string = join(",", map {$dbh->quote($_);} values %{$namelist_ref});
      return "INSERT INTO $curr_table ($keys_string) VALUES ($values_string)";
    }
  } else {
    warn "create_insert_sql: must supply an array reference of column names, or a hash reference of name/value pairs";
    return undef;
  }
}

#----------------------------------------------------------------------


=item create_select_sql($dbh,
           COLUMNS=>$array_ref, 
           FROM=>$array_ref, 
           WHERE=>$string, 
           DISTINCT=>$bool, 
           LIMIT=>$integer)

Takes an array reference of column names to select from an array
reference of table names used in the FROM clause, a string WHERE
clause, and a boolean DISTINCT flag and returns a SQL string to fetch
the requested data. A LIMIT clause will be added if the LIMIT
parameter is specified.

B<Return value>: an SQL string that is specific to the driver for
$dbh (currently this is only implemented for PostgeSQL).

=cut

sub create_select_sql {
  my ($dbh,%args) = @_;
  assert_dbh($dbh);

  for (qw(COLUMNS FROM)) {
    croak "Required element '$_' not defined" unless exists $args{$_};
  }

  my $sql;
  if ($dbh->dbms() eq 'Pg') {
    $sql = 'SELECT ';
    
    # add a distinct modifier if requested
    $sql .= 'DISTINCT ' if exists $args{DISTINCT};
    
    # add the columns
    unless (ref($args{COLUMNS}) eq 'ARRAY') {
      warn "create_select_sql: COLUMNS must be an array reference of column names";
      return undef;
    }
    $sql .= join(', ', @{$args{COLUMNS}});
    
    # and the table names
    unless (ref($args{COLUMNS}) eq 'ARRAY') {
      warn "create_select_sql: FROM must be an array reference of table names";
      return undef;
    }
    $sql .= ' FROM ';
    $sql .= join(', ', @{$args{FROM}});
    
    # and a where clause if requested
    if (exists $args{WHERE} && $args{WHERE} ne '') {
      $sql .= ' WHERE ' . $args{WHERE};
    }
    
    # and a where clause if requested
    if (exists $args{LIMIT} && $args{LIMIT} ne '') {
      $sql .= ' LIMIT ' . $args{LIMIT};
    }
  } else {
    carp "Bio::Genex::DBUtils::create_select_sql: Driver ", $dbh->dbms(), " not implemented";
  }

  return $sql;
}
#----------------------------------------------------------------------

=item lookup_usf_id($dbh,$sequence_feature_name,$approx)

Given a sequence feature name, this function returns the primary key
in the DB for that sequence feature.

If the optional C<$approx> flag is specified, then C<lookup_usf_id()>
will use wildcarding around C<$sequenc_feature_name> so the name does not have
to be an exact match.

=cut


sub lookup_usf_id {
  my ($dbh,$seq_feat,$approx) = @_;
  
  return lookup_id($dbh,'UserSequenceFeature','usf_name','usf_pk',
		   $seq_feat,$approx);;
}
#----------------------------------------------------------------------

=item assert_dbh($dbh)

This method ensures that $dbh is a valid instance of class
Bio::Genex::Connect, otherwise it triggers an exception.

=cut

sub assert_dbh {
  my $dbh = shift;
  return if ref($dbh) && $dbh->isa('Bio::Genex::Connect');

  # Oops, someone blew it, give them a useful error message
  # first figure out who called us
  my @caller = caller(1);
  my $subroutine = $caller[3];

  if (ref($dbh) && $dbh->isa('DBI::db')) {
    croak "Invalid DB handle. Cannot use DBI::connect()\nto create a DB handle for $subroutine,\nmust create DB handle using Bio::Genex::current_connection() or Bio::Genex::_connect()";
  } else {
    croak "$subroutine expected a database handle, but got: '$dbh'";
  }
}

=item assert_table_defined($dbh,$table_name)

This ensures that $table_name exists in $dbh, otherwise it triggers an
exception. This method caches its results for all tables it finds for
$dbh. This significantly speeds up all future calls for all tables.

=cut


sub assert_table_defined
{
  my ($dbh,$table) = @_;
  assert_dbh($dbh);
  if ($dbh->dbms() eq 'Pg') {
    $table = lc($table);	# this probably only works for postgres
  }
  # retrieve the table name cache for this DB, and use the cache
  my $cache = $dbh->tables();
  return if exists $cache->{$table}; # use the cache first

  # otherwise we need to access the DB
  assert_dbh($dbh);

  # verify presence of this table
  my $found = 0;
  my $modified = 0;
  my $sth = $dbh->table_info || die $DBI::errstr;
  while (my ($name,$type) = ($sth->fetchrow_array)[2..3]) {
    die $DBI::errstr if $sth->err;

    # we only want tables
    next unless $type eq 'TABLE';

    $modified = 1;

    # store this table in the cache for later
    $cache->{$name} = 1;
    if ($name eq $table) {
      $found = 1;
      last;
    }
  }
  $sth->finish;
  $dbh->tables($cache) if $modified; # update the cache, if modified

  die "Table $table not found" unless $found;
}
#----------------------------------------------------------------------

=item lookup_contact_id($dbh,$contact_name,$approx)

Given a contact person name, this function returns the primary key
in the DB for that contact.

If the optional C<$approx> flag is specified, then C<lookup_contact_id()>
will use wildcarding around C<$contact_name> so the name does not have
to be an exact match.

=cut


sub lookup_contact_id {
  my ($dbh,$contact,$approx) = @_;
  
  return lookup_id($dbh,'Contact','contact_person','con_pk',$contact,$approx);
}
#----------------------------------------------------------------------

=item lookup_software_id($dbh,$software_name,$approx)

Given a software name, this function returns the primary key
in the DB for that software.

If the optional C<$approx> flag is specified, then C<lookup_software_id()>
will use wildcarding around C<$software_name> so the name does not have
to be an exact match.

=cut


sub lookup_software_id {
  my ($dbh,$name,$approx) = @_;

  return lookup_id($dbh,'Software','name','sw_pk',$name,$approx);
}
#----------------------------------------------------------------------

=item lookup_species_id($dbh,$species_name,$approx)

Given a primary scientific name, this function returns the primary key
in the DB for that species. 

If the optional C<$approx> flag is specified, then C<lookup_species_id()>
will use wildcarding around C<$species_name> so the name does not have
to be an exact match.

=cut


sub lookup_species_id {
  my ($dbh,$name,$approx) = @_;

  return lookup_id($dbh,'Species','primary_scientific_name','spc_pk',
		   $name,$approx);
}
#----------------------------------------------------------------------

=item lookup_experiment_id($dbh,$experiment_name)

Given an experiment set name, this function returns the primary key
in the DB for that experiment set.

If the optional C<$approx> flag is specified, then C<lookup_experiment_id()>
will use wildcarding around C<$experiment_name> so the name does not have
to be an exact match.

=cut


sub lookup_experiment_id {
  my ($dbh,$name,$approx) = @_;

  return lookup_id($dbh,'ExperimentSet','name','es_pk',$name,$approx);
}
#----------------------------------------------------------------------

=item lookup_id($dbh,$table,$attribute,$pk_name,$value,$approx)

Retrieves the primary key ($pk_name) for a row in $table whose
$attribute column is $value). 

The optional $approx flag species that approximate mathcing using an
SQL 'LIKE' clause should used instead of exact matching using '='.

=cut


sub lookup_id {
  my ($dbh,$table,$attribute,$pk_name,$value,$approx) = @_;
  
  $table = lc $table;

  # sanity checks
  assert_dbh($dbh);
  assert_table_defined($dbh,$table);

  my $sql = "select $pk_name from $table where $attribute ";
  if (defined $approx) {
    $sql .= ' LIKE ';
    $value = "%$value%";
  } else {
    $sql .= ' = ';
  }
  $sql .= qq{'$value'};
  
  my $id = ($dbh->selectrow_array($sql))[0];
  unless (defined $id) {
    croak "lookup_id: value \'$value\' not found for attribute \'$attribute\'in table \'$table\' using pkey name \'$pk_name\'";
  }
  return $id;
}
#----------------------------------------------------------------------

=item fetch_last_id($dbh,$table)

Retrieves the primary key of the last row inserted into $table.

=cut


sub fetch_last_id {
  my ($dbh,$table) = @_;
  assert_dbh($dbh);

  my $id;
  if ($dbh->dbms() eq 'Pg') {
    my $class = "Bio::Genex::$table";
    eval "require $class";
    my $pkey = $class->pkey_name();

    #
    # We need to store the newly create id
    #    ### NOTE ### this is totally Pg dependant and should be changed
    #
    my $sql = 'SELECT last_value FROM ' . $table . '_' . $pkey . '_seq';

    $id = ($dbh->selectrow_array($sql))[0];
    unless (defined $id) {
      warn "Bio::Genex::DBUtils::fetch_last_id: $table: id not found\n";
    }
  } else {
    carp "Bio::Genex::DBUtils::fetch_last_id: Driver ", $dbh->dbms(), " not implemented";
  }
  return $id;
}


#----------------------------------------------------------------------

=item check_password($dbh,$user_name,$password)

Checks whether there exists an entry in the UserSec table whose
'login' == $user_name and 'password' == $password. 

Return value: 
  On Success: the primary key of the UserSec entry
  On Failure: undef

=cut


sub check_password {
  my ($dbh,$user_name,$password) = @_;
  assert_dbh($dbh);

  require Bio::Genex::UserSec;
  my @users = Bio::Genex::UserSec->get_objects({column=>'login',value=>$user_name});
  die "Bio::Genex::DBUtils::check_password: found more than one user for login: $user_name"
    if scalar @users > 1;
  die "Bio::Genex::DBUtils::check_password: found more no users for login: $user_name"
    if scalar @users < 1;

  # passwords are stored using crypt(). The first two letters of the login
  # are used for salt
  my $salt = substr($user_name,0,2);
  return ($users[0]->password eq crypt($password,$salt) 
	  ? $users[0]->us_pk 
	  : undef
	 );
}


=item fetch_es_ids()

Retrieves the primary keys of all experiment sets in the DB.

=cut

sub fetch_es_ids {
  my $dbh = Bio::Genex::current_connection();
  require Bio::Genex::ExperimentSet;
  my @objects;
  my @ids;
  push(@objects, Bio::Genex::ExperimentSet->get_objects('ALL'));
  foreach (@objects) {
    $_->fetch();
    push(@ids,$_->es_pk);
  }
  return @ids;
}


=item fetch_am_ids($es_pk, @am_types)

Retrieves the primary keys of all array measurements belonging to
experiment set $es_pk. 

The optional @am_types list is used to filter the arrays to a given
type. There is no default value for this parameter.

Return Value:
   list of ArrayMeasurement ids or undef if none.

=cut

sub fetch_am_ids {
  my ($es_pk,@am_types) = @_;
  require Bio::Genex::ArrayMeasurement;
  my @objects;
  my @ids;

  # need a valid connection for create_select_sql
  my $dbh = Bio::Genex::current_connection();

  my $WHERE = "primary_es_fk = $es_pk ";
  if (scalar @am_types) {
    $WHERE .= 'AND (';
    $WHERE .= 'type=\'' . join('\' OR type=\'',@am_types);
    $WHERE .= '\')';
  }
  my $sql = create_select_sql($dbh,COLUMNS=>['am_pk'],
			      FROM=>['ArrayMeasurement'],
			      WHERE=>$WHERE,
			     );

  # execute the sql
  my $sth = $dbh->prepare($sql) || die $DBI::errstr;
  $sth->execute() || die $DBI::errstr;
  return unless $sth->rows();

  my $array_ref = $sth->fetchall_arrayref() || die $DBI::errstr;
  foreach (@{$array_ref}) {
    push(@ids,$_->[0])
  }
  return @ids;
}



=item fetch_spot_data($es_pk,@am_types)

Fetches all spot data from AM_Spots for all arrays of ExperimentSet $es_pk. 

The optional @am_types list will restrict the retrieval to only arrays
of the specified types, the default value of @am_types is
('derived ratio').

B<Return value>: an instance of C<Bio::Genex::ExperimentSet>

Example use:

  use Bio::Genex::DBUtils qw(fetch_spot_data, fetch_es_ids)
  my @es_ids = fetch_es_ids();
  foreach my $es_pk (@es_ids) {
    my $es = fetch_spot_data($es_pk);
    my @array_list = $es->arraymeasurement_fk();
    foreach my $array (@array_list) {
      my $spot_list_ref = $array->am_spots_fk();

      # locate the column for the spot values
      my @header = shift @{$spot_list_ref};
      my $spot_col;
      my $usf_col;
      for (my $i=0;$i<scalar @header;$i++) {
        $spot_col = $i if $header[$i] =~ /spot_value/;
        $usf_col = $i if $header[$i] =~ /usf_fk/;
      }
      die "Couldn't find columns for " . $array->name() 
        unless defined $spot_col && defined $usf_col;
      
      foreach my $spot (@{$spot_list_ref}) {
        print "$spot->[$usf_col]\t$spot->[$spot_col]";
      }
    }
  }

=cut



sub fetch_spot_data {
  my ($es_pk,@am_types) = @_;

  require Bio::Genex::ExperimentSet;
  
  my $experiment = Bio::Genex::ExperimentSet->new(id=>$es_pk,
					    );
  
  @am_types = ('derived ratio') unless scalar @am_types >= 1;

  # Get the list of array measurements
  my @arrays_to_fetch = fetch_am_ids($es_pk,@am_types);
  
  my @array_objs;
  foreach my $id (@arrays_to_fetch) {
    my $am = Bio::Genex::ArrayMeasurement->new(id=>$id);
#    $Bio::Genex::AM_Spots::_LIMIT = 10;
    $am->am_spots_obj();
    push(@array_objs, $am);
  }
  # set the array measurements to be *only* the ones we need
  $experiment->arraymeasurement_fk(\@array_objs);
  return $experiment;
}




=item output_spot_data($file_handle, $es_pk, @am_types)

Writes all of the spot data belonging to experiement set $es_pk, to
$file_handle. 

The optional @am_types list is used to filter the spot data belonging
to only arrays of the given types. The default value is
C<('derived ratio')>.

=cut




sub output_spot_data {
  my ($fh,$es_pk,@am_types) = @_;
  @am_types = ('derived ratio') unless scalar @am_types >= 1;

  # Get the list of array measurements
  my @arrays_to_fetch = fetch_am_ids($es_pk,@am_types);
  
  # declare the sequence feature cache table
  my %SEQ_FEAT;
  my @rows;

  # need a valid connection for create_select_sql
  my $dbh = Bio::Genex::current_connection();

  # setup the where clause
  my $WHERE .= '( ';
  $WHERE .= 'am_fk=' . join(' OR am_fk=',@arrays_to_fetch);
  $WHERE .= ')';

  my $sql = create_select_sql($dbh,COLUMNS=>['usf_fk','am_fk','spot_value'],
			      FROM=>['AM_Spots'],
			      WHERE=>$WHERE,
			     );
  # execute the sql
  my $sth = $dbh->prepare($sql) || die $DBI::errstr;
  $sth->execute() || die $DBI::errstr;
  my $rows = $sth->rows || die $DBI::errstr;
  
  my %results;
  while (my ($usf_pk,$am_fk,$value) = $sth->fetchrow_array()) {
    unless (exists $SEQ_FEAT{$usf_pk}) {
      
      #
      # *** HACK ALERT ***
      #
      # This is not the best way to preload the sequence feature cache
      # but given the current DB layout, it's the only way
      # if we ever get a sequence feature that we don't recognize
      # we look at it's species and prefetch all the rest of the
      # sequence features from the species. 
      # 
      # really what we want is a linking table from ArrayMeasurement
      # to Species and precache them that way.
      #
      
      # first figure out the species
      my $species_sql = create_select_sql($dbh,COLUMNS=>['spc_fk'],
					  FROM=>['UserSequenceFeature'],
					  WHERE=>"usf_pk=?",
					 );

      my $species_sth = $dbh->prepare($species_sql) || die $DBI::errstr;
      $species_sth->execute($usf_pk) || die $DBI::errstr;
      my $species = ($species_sth->fetchrow_array())[0];
      
      # now get all the sequence features
      my $seq_feat_sql = create_select_sql($dbh,
					   COLUMNS=>['usf_pk','usf_name','usf_type'],
					   FROM=>['UserSequenceFeature'],
					   WHERE=>"spc_fk=?",
					  );
      
      my $seq_feat_sth = $dbh->prepare($seq_feat_sql) || die $DBI::errstr;
      $seq_feat_sth->execute($species) || die $DBI::errstr;
      while (my ($usf_pk,$usf_name,$usf_type) = $seq_feat_sth->fetchrow_array()) {
	$SEQ_FEAT{$usf_pk} = [$usf_name,$usf_type];
      }
    }
    $results{$usf_pk}->{$am_fk} = $value;
  }
  my $time = localtime;
  my $array_header = join("\t",@arrays_to_fetch);
    print $fh <<"EOF";
#
# Data from ExperimentSet $es_pk, retrieved on $time
#
#Feature Name\tFeature Type\t$array_header
EOF
    
  foreach my $usf_pk (sort keys %results) {
    my $out = "$SEQ_FEAT{$usf_pk}->[0]\t$SEQ_FEAT{$usf_pk}->[1]\t";
    foreach my $am_fk (keys %{$results{$usf_pk}}) {
      $out .= "$results{$usf_pk}->{$am_fk}\t";
    }
    # replace the final tab with an end of line
    substr($out,-1) = "\n";
    print $fh $out;
  }
}

=item fetch_fkey_list(dbh=>$dbh,calling_class=>$table_name,class_to_fetch=>$table_name,column_to_fetch=>$column_name,value_to_fetch=>$pkey)

B<Parameters:> C<dbh>: a database handle; C<calling_class>: the name
of the class requesting the data; C<class_to_fetch> the name of the
table to lookup the data from; C<column_to_fetch>: the name of foreign
key in C<class_to_fetch> that refers to C<calling_class>;
C<value_to_fetch>: the value of C<column_to_fetch> to use in the
C<WHERE> clause.

B<Control Variables:> Setting C<$Bio::Genex::DBUtils::NO_FETCH_DISTINCT>
instructs fetch_fkey_list to not use the C<DISTINCT> SQL keyword in
the query (the default is to use C<DISTINCT>. Setting
C<$Bio::Genex::DBUtils::NO_FETCH_ALL> instructs the method to not set the
C<fetch_all> parameter when calling C<new()> on each object (the
default is to use C<fetch_all>).

=cut
  
sub fetch_fkey_list {
  my (%args) = @_;
  foreach (qw(dbh 
	      calling_class 
	      class_to_fetch 
	      column_to_fetch 
	      value_to_fetch)) {
    die "Must specify $_ argument to DBUtils::fetch_fkey_list" 
      unless exists $args{$_};
  }
  my $dbh = $args{dbh};
  assert_dbh($dbh);

  # if we are given class names, translate them to table names
  $args{class_to_fetch} =~ s/Bio::Genex:://;
  $args{calling_class} =~ s/Bio::Genex:://;

  # make sure the fkey points to a real table
  assert_table_defined($dbh,$args{class_to_fetch});

  # get the primary key name for the foreign table
  my $class = 'Bio::Genex::' . $args{class_to_fetch};
  # we specify calling_class in case $class is a linking table
  eval "require $class;";
  die "Bio::Genex::DBUtils::fetch_fkey_list: Couldn't eval $class: $@" if $@;
  my $fkey_pkey_name =   $class->pkey_name($args{calling_class});

  croak "No PKEY for $args{class_to_fetch}" unless defined $fkey_pkey_name;
  my @sql_args = (COLUMNS=>[$fkey_pkey_name],
		  FROM=>[$args{class_to_fetch}], 
		  WHERE=>"$args{column_to_fetch} = '$args{value_to_fetch}'");
  {
    no strict 'refs';
    my $limit = $ {"${class}::LIMIT"};
    if ($limit) {
      push(@sql_args,LIMIT=>$limit);
    }
  }
  unless ($NO_FETCH_DISTINCT) {
    push(@sql_args,DISTINCT=>1);
  }
  my $sql = create_select_sql($dbh,@sql_args);
  my $sth = $dbh->prepare($sql) || carp $DBI::errstrstr;
  $sth->execute() || carp $DBI::errstr;

  my @objs;
  my $i;
  while (my $ref = $sth->fetchrow_arrayref()) {
    $i++;
    print STDERR "Accessing $args{class_to_fetch} $i\n" 
      if $DEBUG && $i % 250 == 0;

    carp $DBI::errstr if $sth->err;

    # now that we have the primary key, we create a new instance
    my $obj;
    my @new_args = (id=>$ref->[0]);
    unless ($NO_FETCH_ALL) {
      push(@new_args, fetch_all=>1);
    }
    if ($class->linking_table) {
      push(@new_args, pkey_link=>$fkey_pkey_name);
    } 
    $obj = $class->new(@new_args);

    # and store the completed object
    push(@objs,$obj);
  }
  $sth->finish();
  return \@objs;
}

=item fetch_user_al_ids($us_fk)

Find all ArrayLayouts for a given user.

Return Value:
   a list of ArrayLayout ids or undef if none.

=cut

sub fetch_user_al_ids {
  my $us_fk = shift;
  my $dbh = Bio::Genex::current_connection();
  
  assert_table_defined($dbh,'ArrayLayout');
  assert_table_defined($dbh,'ArrayMeasurement');
  my $sql = create_select_sql($dbh,
			      COLUMNS=>['al_fk'],
			      FROM=>['ArrayMeasurement'],
			      WHERE=>"us_fk = $us_fk",
			      DISTINCT=>1,
			     );
  my $layout_ref = $dbh->selectall_arrayref($sql)->[0];
  die $DBI::errstr if $dbh->err;
  return unless defined $layout_ref;
  return @{$layout_ref};
}


=item fetch_es_species($es_pk)

Parameters: $es_pk, the primary key for the ExperimentSet whose species are 
being queried.

Return value: an instance of class C<Bio::Genex::Species>.

=cut


  #
  # *** HACK ALERT ***
  # 
  # This method of filtering on species assumes that there is only
  # a single species per experiment set ==> THIS IS WRONG 
  # Until we get the linking table between ArrayMeasurement and Species
  # this is the only efficient way I could come up with
  #
sub fetch_es_species {
  my ($dbh,$es_pk) = @_;

  # first get any old ArrayMeasurement from the experiment
  my $sql = create_select_sql($dbh,COLUMNS=>['am_pk'],
			      FROM=>['ArrayMeasurement'],
			      WHERE=>"primary_es_fk = $es_pk",
			      LIMIT=>1,
			     );
  my $am_pk = ($dbh->selectrow_array($sql))[0] || die $DBI::errstr;
  
  # now get any old sequence feature from that array
  $sql = create_select_sql($dbh,COLUMNS=>['usf_fk'],
			   FROM=>['AM_spots'],
			   WHERE=>"am_fk = $am_pk",
			   LIMIT=>1,
			  );
  my $usf_fk = ($dbh->selectrow_array($sql))[0] || die $DBI::errstr;
  
  # finally get the species of that sequence feature
  $sql = create_select_sql($dbh,COLUMNS=>['spc_fk'],
			   FROM=>['UserSequenceFeature'],
			   WHERE=>"usf_pk = $usf_fk",
			  );
  my $spc_fk = ($dbh->selectrow_array($sql))[0] || die $DBI::errstr;
  require Bio::Genex::Species;
  return Bio::Genex::Species->new(id=>$spc_fk);
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__

=back




=head1 AUTHOR

Jason Stewart (jes@ncgr.org), and Peter Hraber (pth@ncgr.org)

=head1 SEE ALSO

perl(1).

=cut
