package pt2_general;

use strict;
use Carp;
use WrapDBI;
use vars qw(@ISA @EXPORT);
use Exporter;
@ISA = ('Exporter');
@EXPORT = qw(&id_person2id_role);

# id_person2id_role( ... , $mw)
#
#   Assumes "use Tk" done already, for the case of multi-team role.
#
#   This sub tested OK on Tru64 5.6.1, Tru64 5.8.0 and Deskpro Debian
# 5.8.4


# Other functions
#
#   Look like they'll probably work no worse than they did under
# 5.004.
#
#   For several interpolations of @$id_seqchems, $" is apparently not
# set.  Does it work for more than one ID?  Also, SQL injection is
# possible


sub id_person2id_role {
    #################################################################
    # Supply a user and a particular roletype and this will allow
    # a choice of team (if the user is registered to multiple teams)
    #################################################################

    my ($dbh, $id_person, $role_type, $mw) = @_;

    my $statement = "select id_role, teamname 
                     from   team_person_role 
                     where  id_person = ? -- $id_person 
                     and    iscurrent = 1 
                     and    roletype =  ? -- $role_type  
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $id_person);
    $sth1->bind_param(2, $role_type);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_role, $teamname);
    my $c = 0;
    my %hash;
    while ( ($id_role, $teamname)  = $sth1->fetchrow() ){
	$c++;
	$hash{$teamname} = $id_role; 
    }
    $sth1->finish();
    
    my @possibles = (keys %hash);
    
    if ($c == 0){
	$id_role = "Not a $role_type person";
	
    } elsif ($c > 1){
	##################################################################
	# The user must decide for whom they are working in this session
	##################################################################
	my $choice;
	my $win = $mw->Toplevel;
	$win->focusForce;
	$win->grab;
	$win->configure (-title => "$role_type team selector");
	my $frame = $win->Frame();
	my $label = $frame->Label(-text => "Who are you currently working for ?");
	$label->pack(-side=> 'top');
	my $scrllist = $frame->ScrlListbox (
					    -bg => 'lemonchiffon1',
					    -scrollbars => 'e',
					    -label => "You can choose from the following.",
					    -height => 5,
					    -width => 30
					    );
	$scrllist->bind ('<Double-Button-1>' => sub { 
	    $choice = $scrllist->get('active');
	    if ($choice eq ''){
		return;
	    }
	    $id_role = $hash{$choice};
	    $teamname = $choice;
	    $win->destroy();
	});
	
	$scrllist->pack(-side => 'left', -expand => 1, -fill => 'both');
	$scrllist->insert('end', @possibles);
	$frame->pack;
	$frame->waitWindow;
    } else {
	my @array = %hash;
	$id_role = $array[1];
	$teamname = $array[0];
    }

    return ($id_role, $teamname);
}


#####################################################################
#
# The following subroutines are used in pt2_seq.
# They allow the selection of a unique id_scsp by 'wittling'
# down a passed list of seqchems; ie. everytime the user spcifies
# another parameter of the chemistry they require the list of valid 
# seqchemistry.id_seqchem may reduce or stay the same.
#
#####################################################################

sub seqchems_wrt_protocol {
    my ($dbh, $id_protocol) = @_;
    
    my $statement = "
select distinct seqchemistry.id_seqchem 
from seqchem_seqprotocol, seqchemistry
where seqchem_seqprotocol.id_seqchem = seqchemistry.id_seqchem
and id_protocol = ?
and seqchemistry.is_westpav = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $id_protocol);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    
    # Send back the seqchems
    return (\@a);
}


sub list_of_dyesets {
    my ($dbh, $id_seqchems) = @_;

    # Note that the following statement cannot be made
    # with bind vars with the current mode of operation
    my $statement = "
select dyeset.id_dyeset, dyeset.name
from seqchemistry, dyeset
where seqchemistry.id_dyeset = dyeset.id_dyeset
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my ($id_dict, $description);
    my %hash;
    while ( ($id_dict, $description) = $sth1->fetchrow() ){
	$hash{$description} = $id_dict;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_dyeset {
    my ($dbh, $id_dyeset, $id_seqchems) = @_;
    my $statement = "
select distinct id_seqchem
from seqchemistry 
where id_dyeset = ?
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $id_dyeset);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub list_of_directions {
    my ($dbh, $id_seqchems) = @_;
    my $statement = "
select distinct pt_vector.is_fwd
from pt_vector, seqchemistry
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $id;
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	my $description;
	if ($id == 1){
	    $description = 'Forward';
	} else {
	    $description = 'Reverse';
	}
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_direction {
    my ($dbh, $direction, $id_seqchems) = @_;
    
    my $statement = "
select distinct id_seqchem
from seqchemistry, pt_vector
where seqchemistry.id_ptv = pt_vector.id_ptv
and pt_vector.is_fwd = ?
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $direction);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}


sub list_of_terms {
    my ($dbh, $id_seqchems) = @_;
    my $statement = "
select distinct seqchemistry.is_primer
from seqchemistry
where seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $id;
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	my $description;
	if ($id == 1){
	    $description = 'Primer';
	} else {
	    $description = 'Terminator';
	}
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_term {
    my ($dbh, $term, $id_seqchems) = @_;
    my $statement = "
select distinct id_seqchem
from seqchemistry 
where seqchemistry.is_primer = ?
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";
    
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $term);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}


sub list_of_vectors {
    my ($dbh, $id_seqchems) = @_;

    my $statement = "
select distinct pt_vector.vectorname
from pt_vector, seqchemistry
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
order by pt_vector.vectorname
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $description;
    my $id = 0;
    my %hash;
    while ( ($description) = $sth1->fetchrow() ){
	$id++;
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}

sub seqchems_wrt_vector {
    my ($dbh, $vectorname, $id_seqchems) = @_;
    
    my $statement = "
select distinct id_seqchem
from seqchemistry, pt_vector
where seqchemistry.id_ptv = pt_vector.id_ptv
and pt_vector.vectorname = ? 
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $vectorname);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}

sub list_of_primers {
    my ($dbh, $id_seqchems) = @_;

    my $statement = "
select distinct pt_vector.primername
from pt_vector, seqchemistry
where seqchemistry.id_ptv = pt_vector.id_ptv
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";


    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $description;
    my $id = 0;
    my %hash;
    while ( ($description) = $sth1->fetchrow() ){
	$id++;
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}

sub seqchems_wrt_primer {
    my ($dbh, $primername, $id_seqchems) = @_;

    my $statement = "
select distinct id_seqchem
from seqchemistry, pt_vector
where seqchemistry.id_ptv = pt_vector.id_ptv
and pt_vector.primername = ? 
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $primername);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}



sub list_of_pcrs {
    my ($dbh, $id_seqchems) = @_;
    my $statement = "
select distinct seqchemistry.is_pcr
from seqchemistry
where seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";

    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $id;
    my %hash;
    while ( ($id) = $sth1->fetchrow() ){
	my $description;
	if ($id == 1){
	    $description = 'Yes';
	} else {
	    $description = 'No';
	}
	$hash{$description} = $id;
    }
    $sth1->finish();
    return (\%hash);
}


sub seqchems_wrt_pcr {
    my ($dbh, $pcr, $id_seqchems) = @_;
    my $statement = "
select distinct id_seqchem
from seqchemistry 
where seqchemistry.is_pcr = ?
and seqchemistry.id_seqchem in ( @$id_seqchems )
and seqchemistry.is_westpav = 1
";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $pcr);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my @a;
    my $s;
    while ( $s = $sth1->fetchrow() ){
	push @a, "$s";
	push @a, ",";
    }
    pop @a;
    $sth1->finish();
    return (\@a);
}


# ??? Candidate for sql_engine ???
sub suffix_from_seqchem {
    my ($dbh, $id_seqchems) = @_;
    my $statement = "
select distinct suffix
from seqchemistry 
where seqchemistry.id_seqchem = ?
and seqchemistry.is_westpav = 1
";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $id_seqchems->[0]);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $s = $sth1->fetchrow();
    return ($s);
}


# ??? Candidate for sql_engine ???
sub id_scsp_wrt_id_seqchem_and_id_protocol {
    my ($dbh, $id_seqchems, $id_protocol) = @_;
    my $statement = "
select id_scsp
from seqchem_seqprotocol 
where id_seqchem =  ?
and id_protocol = ?
";
    my $sth1 = $dbh->prepare($statement) || die "ERROR:$DBI::errstr";
    $sth1->bind_param(1, $id_seqchems->[0]);
    $sth1->bind_param(2, $id_protocol);
    $sth1->execute || die "ERROR:$DBI::errstr";
    my $s = $sth1->fetchrow();
    return ($s);   
}



1;
