package Tracking;

use strict;
use WrapDBI;
use Kill_Equus;
use Carp;

sub new {
    my ($type, %opts) = @_;

    my $self = {
	dbh           => undef,
	cache_results => $opts{cache_results} || 0,
	results_cache => {},
	cache_sth     => $opts{cache_sth} || 1,
	sth_cache     => {},
    };

    bless($self, $type);

    if (defined($opts{dbh})) {
	$self->{dbh} = $opts{dbh};
    } else {
	$self->open_database($opts{login});
    }

    return $self;
}

sub DESTROY {
    my ($self) = @_;

    if (defined($self->{dbh})) {
	$self->{dbh}->disconnect;
    }
}

# Open the connection to the database.
# If no login is given, connect as reports (i.e. read only)

sub open_database {
    my ($self, $login) = @_;

    unless (defined($login)) { $login = 'reports'; }

    $self->{dbh} = WrapDBI->connect($login, {
	RaiseError => 1,
	AutoCommit => 0,
    });
}

# Open equus (should we need it)

sub open_equus {
    my ($self) = @_;

    if (exists($self->{equus_db})) { return; }

    my ($edi, $equus_db) = Kill_Equus::openEquus('reports');

    $self->{edi}      = $edi;
    $self->{equus_db} = $equus_db;
}

# Statement handle caching for oracle

sub prepare {
    my ($self, $sql) = @_;

    my $sth = eval {
	my $sth_cache = $self->{sth_cache};
	
	if ($self->{cache_sth} && exists($sth_cache->{$sql})) {
	    return $sth_cache->{$sql};
	}
	
	my $dbh = $self->{dbh};
	
	my $sth = $dbh->prepare($sql);
	
	if ($self->{cache_sth}) { $sth_cache->{$sql} = $sth; }

	return $sth;
    };

    if ($@) {
	confess($@);
    }

    return $sth;
}

sub fetchrow_hash {
    my ($self, $sth, @keys) = @_;

    my @data;
    eval {
	@data = $sth->fetchrow_array();
    };

    if ($@) {
	my $a = $@;
	$a =~ s/\s+at\s+(\S+)\s+line\s+\d+\.\s*$//;
	croak($a);
    }

    unless (@data) { return; }
    
    my %res;

    for (my $i = 0; $i < @keys; $i++) {
	$res{$keys[$i]} = $data[$i];
    }

    return \%res;
}

# Results cacheing

sub add_cache {
    my ($self, $cache_type, $key, $data) = @_;

    unless ($self->{cache_results}) { return; }

    $self->{results_cache}->{$cache_type}->{$key} = $data;
}

sub check_cache {
    my ($self, $cache_type, $key) = @_;

    unless ($self->{cache_results}) { return; }

    unless (exists($self->{results_cache}->{$cache_type}->{$key})) { return; }

    return $self->{results_cache}->{$cache_type}->{$key};
}


sub get_clone_info {
    my ($self, $clone) = @_;

    if (my $res = $self->check_cache(clone_info => $clone)) { return $res; }

    my $sth =
	$self->prepare(qq[select c.speciesname, cd.description, l.libraryname,
			         l.id_vectorsite,
		                 vs.vectorname, vs.stadenfile, vs.fastafile,
			         cd.chromosome, ctd.description
			  from   clone c, chromosomedict cd,
                                 library l, vectorsite vs,
			         clonetypedict ctd
			  where  c.clonename          = ?
			  and    cd.id_dict       (+) = c.chromosome
			  and    l.libraryname    (+) = c.libraryname
			  and    vs.id_vectorsite (+) = l.id_vectorsite
			  and    ctd.id_dict          = c.clone_type]);
    $sth->execute($clone);
    my $res = $self->fetchrow_hash($sth, qw(speciesname chromosome libraryname
					    id_vectorsite
					    vectorname stadenfile fastafile
					    chromosome_code clone_type));
    $sth->finish();

    $self->add_cache(clone_info => $clone, $res);

    return $res;
}

sub get_cloning_vector_info_for_clone {
    my ($self, $clone) = @_;

    if (my $res = $self->check_cache(vector_info_for_clone => $clone)) {
	return $res;
    }

    my $sth = 
	$self->prepare(qq[select vs.vectorname, vs.stadenfile, vs.fastafile
			  from   clone c, library l, vectorsite vs
			  where  c.clonename      = ?
			  and    l.libraryname    = c.libraryname
			  and    vs.id_vectorsite = l.id_vectorsite]);
    $sth->execute($clone);
    my $res = $self->fetchrow_hash($sth, qw(vectorname stadenfile fastafile));
    $sth->finish();

    $self->add_cache(vector_info_for_clone => $clone, $res);

    return $res;
}

sub get_projects_for_clone {
    my ($self, $clone) = @_;

    if (my $res = $self->check_cache(projects_for_clone => $clone)) {
	return $res;
    }

    my $sth = 
	$self->prepare(qq[select projectname
			  from   clone_project
			  where  clonename = ?]);

    $sth->execute($clone);
    my $res = $sth->fetchall_arrayref();
    $sth->finish();

    $self->add_cache(projects_for_clone => $clone, $res);

    return $res;
}

sub get_project_info {
    my ($self, $project) = @_;

    if (my $res = $self->check_cache(project_info => $project)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select id_online, ext_database, ext_project
				from   project
				where  projectname = ?]);

    $sth->execute($project);
    my $res = $self->fetchrow_hash($sth, qw[id_online
					    ext_database ext_project]);
    $sth->finish();

    $self->add_cache(project_info => $project, $res);

    return $res;
}

sub get_library_info {
    my ($self, $library) = @_;

    if (my $res = $self->check_cache(library_info => $library)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select INTERNAL_PREFIX, EXTERNAL_PREFIX,
				       SPECIESNAME, CHROMOSOME,
				       ID_VECTORSITE
				from   library
				where  LIBRARYNAME = ?]);

    $sth->execute($library);

    my $res = $self->fetchrow_hash($sth,
				   qw[internal_prefix external_prefix
				      speciesname chromosome
				      id_vectorsite]);

    $sth->finish();

    $self->add_cache(library_info => $library, $res);

    return $res;
}

sub get_ligation_info {
    my ($self, $ligation) = @_;

    if (my $res = $self->check_cache(ligation_info => $ligation)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select l.volume, l.positive, l.negative,
				       l.comments, l.clonename,
				       lb.seq_vector, fb.size_from_kb,
				       fb.size_to_kb
				from   ligation l, ligation_batch lb,
				       fragmentation_band fb
				where  l.id_ligation = ?
				and    lb.id_ligbatch = l.id_ligbatch
				and    fb.id_fragband (+) = l.id_fragband]);

    my $res;

    my @keys = qw[volume positive negative comments clonename id_vectorsite
		  min_size max_size];

    if ($ligation =~ /^\d+$/) {
	$sth->execute($ligation);
	$res = $self->fetchrow_hash($sth, @keys);
	$sth->finish();

	unless ($res) {
	    # It's not in oracle - try to add it from equus
	    system('add_ligation_to_oracle_from_equus', $ligation);

	    # See if it worked...
	    $sth->execute($ligation);
	    $res = $self->fetchrow_hash($sth, @keys);
	    $sth->finish();
	}
    }
    
    unless ($res) {
	# not in oracle - have to try equus.

	$self->open_equus();
	my ($clone, $vector, $min_size, $max_size, $volume, $blue, $clear,
	    $fragment_box, $remark)
	    = Kill_Equus::equus_get_ligation_info($self->{equus_db},
						  $ligation);

	if (defined($clone)) {
	    $res = {
		volume     => $volume,
		positive   => $clear,
		negative   => $blue,
		comments   => $remark,
		clonename  => $clone,
		vectorname => $vector,
		min_size   => $min_size,
		max_size   => $max_size,
	    };
	}
    }

    $self->add_cache(ligation_info => $ligation, $res);

    return $res;
}

sub get_vector_info {
    my ($self, $request) = @_;

    if (defined($request->{id_vectorsite})) {

	return $self->get_vectorsite_info($request->{id_vectorsite});

    } elsif (defined($request->{vectorname})) {

	return $self->get_vectorname_info($request->{vectorname});

    } else {

	return;

    }
}

sub get_vectorsite_info {
    my ($self, $id_vectorsite) = @_;

    if (my $res = $self->check_cache(vectorsite => $id_vectorsite)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select vectorname, stadenfile, fastafile,
				       forwardcloningsite, revcloningsite,
				       forwardprimersite, revprimersite
				from   vectorsite
				where  id_vectorsite = ?]);
    $sth->execute($id_vectorsite);
    my $res = $self->fetchrow_hash($sth, qw[vectorname stadenfile fastafile
					    fwd_clone rev_clone
					    fwd_primer rev_primer]);
    $sth->finish();

    $self->add_cache(vectorsite => $id_vectorsite, $res);

    return $res;
}

sub get_vectorname_info {
    my ($self, $vectorname) = @_;

    if (my $res = $self->check_cache(vectorname => $vectorname)) {
	return $res;
    }

    $self->open_equus();

    my $vector = $self->{equus_db}->fetch(-class  => 'Vector',
					  -name   => $vectorname,
					  -filled => 1);

    unless (defined($vector)) { return; }

    my $e_staden = $vector->at("Staden_file[1]");
    my $e_fasta  = $vector->at("Fasta_file[1]");
    my $e_c_site = $vector->at("Clone_site[1]");
    my $e_fwd    = $vector->at("Forward_primer_site[1]");
    my $e_rev    = $vector->at("Reverse_primer_site[1]");
    
    
    my $res = {
	vectorname => $vectorname,
	stadenfile => "$e_staden",
	fastafile  => "$e_fasta",
	fwd_clone  => "$e_c_site",
	fwd_primer => "$e_fwd",
	rev_primer => "$e_rev",
    };

    $self->add_cache(vectorname => $vectorname, $res);

    return $res;
}

sub get_ligation_sil_info {
    my ($self, $ligation) = @_;

    if ($ligation !~ /^\d+$/) { return; }

    if (my $res = $self->check_cache(ligation_sil => $ligation)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select sr.sil_type, sr.id_request, sr.id_source
				from   LIGATION l, FRAGMENTATION_BAND fb,
				       SIL_JOB sj, SIL_REQUEST sr
				where  l.ID_LIGATION = ?
				and    l.ID_FRAGBAND = fb.ID_FRAGBAND
				and    fb.ID_FRAG    = sj.ID_FRAG
				and    sj.ID_REQUEST = sr.ID_REQUEST]);
    
    $sth->execute($ligation);
    my ($sil_type, $id_request, $id_source) = $sth->fetchrow_array();
    $sth->finish();

    unless (defined($sil_type)) {
	$self->add_cache(ligation_sil => $ligation, undef);
	return;
    }
    
    my $res;

    if (1 == $sil_type) {
	$res = $self->lookup_job_type_transposon($id_request, $id_source);
    } elsif (2 == $sil_type) {
	$res = $self->lookup_job_type_subclone($id_request, $id_source);
    } elsif (3 == $sil_type) {
	$res = $self->lookup_job_type_genome_walk($id_request, $id_source);
    } elsif (4 == $sil_type) {
	$res = $self->lookup_job_type_oligo_screen($id_request, $id_source);
    } elsif (5 == $sil_type) {
	$res = $self->lookup_job_type_restriction($id_request, $id_source);
    } elsif (6 == $sil_type || 7 == $sil_type) {
	$res = $self->lookup_job_type_pcr($id_request, $id_source);
    } else {
	die "Unknown SIL type $sil_type\n";
    }

    $res->{id_request} = $id_request;
    $res->{id_source}  = $id_source;

    $self->add_cache(ligation_sil => $ligation, $res);

    return $res;
}

sub lookup_job_type_transposon {
    my ($self, $id_request, $id_source) = @_;

    my $res = $self->lookup_job_dna_source($id_request, $id_source);
    $res->{sil_type} = 'transposon';

    if ($res->{source_type} eq 'subclone') {
	($res->{id_vectorsite}, $res->{ligation}) =
	    $self->lookup_job_source_vector($res->{platename},
					    $res->{row}, $res->{col});
    }

    print STDERR "@{[%$res]}\n";

    return $res;
}

sub lookup_job_type_subclone {
    my ($self, $id_request, $id_source) = @_;

    my $res = $self->lookup_job_dna_source($id_request, $id_source);
    $res->{sil_type} = 'subclone_sil';

    if ($res->{source_type} eq 'subclone') {
	($res->{id_vectorsite}, $res->{ligation}) =
	    $self->lookup_job_source_vector($res->{platename},
					    $res->{row}, $res->{col});
    }

    return $res;
}

sub lookup_job_type_genome_walk {
    my ($self, $id_request, $id_source) = @_;

    my $res = $self->lookup_job_dna_source($id_request, $id_source);
    $res->{sil_type} = 'genome_walk';

    return $res;
}

sub lookup_job_type_oligo_screen {
    my ($self, $id_request, $id_source) = @_;

    my $res = $self->lookup_job_dna_source($id_request, $id_source);
    $res->{sil_type} = 'oligo_screen';

    return $res;
}

sub lookup_job_type_restriction {
    my ($self, $id_request, $id_source) = @_;

    my $res = $self->lookup_job_dna_source($id_request, $id_source);
    $res->{sil_type} = 'restriction';

    # Should probably record enzyme used here, but it doesn't appear to be
    # available in tracking (only the one requested is stored, and this is
    # not compulsory).

    if ($res->{source_type} eq 'subclone') {
	($res->{id_vectorsite}, $res->{ligation}) =
	    $self->lookup_job_source_vector($res->{platename},
					    $res->{row}, $res->{col});
    }

    return $res;
}

sub lookup_job_type_pcr {
    my ($self, $id_request, $id_source) = @_;

    my $res = $self->lookup_job_dna_source($id_request, $id_source);
    $res->{sil_type} = 'pcr';

    return $res;
}

sub lookup_job_dna_source {
    my ($self, $id_request, $id_source) = @_;

    my %source;

    my $sth_sds = $self->prepare(qq[select sds.clonename, sds.platename,
				           rcm.id_map, rcm.maprow, rcm.mapcol
				     from  sil_dnasource sds, rowcol_map rcm
				     where sds.id_source = ?
				     and   rcm.id_map (+) = sds.id_map]);
    $sth_sds->execute($id_source);
    my ($clonename, $platename, $id_map, $row, $col)
	= $sth_sds->fetchrow_array();
    $sth_sds->finish();

    if (defined($platename)) {
	$source{source_type} = 'subclone';
	$source{platename}   = $platename;
	$source{id_map}      = $id_map;
	$source{row}         = $row;
	$source{col}         = $col;
	if ($row && $col) {
	    $source{template}    = sprintf("%s%s%02d", $platename, $row, $col);
	}
    } else {
	my $sth_pcr = $self->prepare(qq[select sp.fwd_primer, sp.rev_primer,
					       sp.est_product_size_kb
					from   sil_pcr sp
					where  sp.id_request = ?]);
	$sth_pcr->execute($id_request);
	my ($fwd_primer_code, $rev_primer_code, $est_size_kb)
	    = $sth_pcr->fetchrow_array();
	$sth_pcr->finish();

	if (defined($fwd_primer_code) || defined($rev_primer_code)) {

	    $source{source_type}     = 'pcr';
	    $source{clonename}       = $clonename;
	    $source{fwd_primer_code} = $fwd_primer_code;
	    $source{rev_primer_code} = $rev_primer_code;
	    $source{est_size_kb}     = $est_size_kb;

	    # This appears to be broken...
# 	    my $sth_primer
# 		= $self->prepare(qq[select p.primerseq
# 				    from   primer p, clone_project cp
# 				    where  cp.clonename = ?
# 				    and    p.projectname = cp.projectname
# 				    and    p.primername = ?]);
#	    
# 	    if (defined($fwd_primer_code)) {
# 		$sth_primer->execute($clonename, $fwd_primer_code);
# 		my ($fwd_primer) = $sth_primer->fetchrow_array();
# 		$sth_primer->finish();
#
# 		if (defined($fwd_primer)) {
# 		    $source{fwd_primer} = $fwd_primer;
# 		}
# 	    }
#    
# 	    if (defined($rev_primer_code)) {
# 		$sth_primer->execute($clonename, $rev_primer_code);
# 		my ($rev_primer) = $sth_primer->fetchrow_array();
# 		$sth_primer->finish();
#
# 		if (defined($rev_primer)) {
# 		    $source{rev_primer} = $rev_primer;
# 		}
# 	    }
	} elsif (defined($clonename)) {
	    $source{source_type} = 'clone';
	    $source{clonename}   = $clonename;
	} else {
	    $source{source_type} = 'unknown';
	}
    }
    
    return \%source;
}

sub lookup_job_source_vector {
    my ($self, $platename, $row, $col) = @_;

    # This should use id_map, but lemur has a bug that means it ignores
    # the plate format when looking it up, so the id_maps in sil_dnasource
    # are not correct.  Bodge this by using the row and column instead.

    my $sth = $self->prepare(qq[select lb.seq_vector, l.id_ligation
				from   beckman_box bb, bb_map bbm,
				       subclone sc, ligation l,
				       ligation_batch lb, rowcol_map rcm
				where  bb.name        = ?
				and    bbm.id_map     = rcm.id_map
				and    rcm.maprow     = ?
				and    rcm.mapcol     = ?
				and    bbm.id_beckmanbox = bb.id_beckmanbox
				and    sc.id_subclone = bbm.id_subclone
				and    l.id_ligation  = sc.id_ligation
				and    lb.id_ligbatch = l.id_ligbatch]);

    $sth->execute($platename, $row, $col);
    my ($id_vectorsite, $id_ligation) = $sth->fetchrow_array();
    $sth->finish();

    return ($id_vectorsite, $id_ligation);
}

sub get_plate_ligation {
    my ($self, $plate) = @_;

    if (my $res = $self->check_cache(plate => $plate)) {
	return $res;
    }

    my $sth1 = $self->prepare(qq[select distinct sc.id_ligation
				 from   subclone sc, bb_map bbm, beckman_box bb
				 where  bb.name           = ?
				 and    bbm.id_beckmanbox = bb.id_beckmanbox
				 and    sc.id_subclone    = bbm.id_subclone]);
    $sth1->execute($plate);
    my $res = $self->fetchrow_hash($sth1, 'ligation');
    $sth1->finish();

    unless ($res) {
	# Check if it's a source_plate

	my $sth2 = $self->prepare(qq[select id_ligation
				     from   source_plate
				     where  platename = ?]);
	$sth2->execute($plate);
	$res = $self->fetchrow_hash($sth2, 'ligation');
	$sth2->finish();
    }

    unless ($res) {
	# see if it's possible to add the plate to Oracle from Equus
	system("add_plate_to_oracle_from_equus", $plate);

	$sth1->execute($plate);
	$res = $self->fetchrow_hash($sth1, 'ligation');
	$sth1->finish();
    }
    unless ($res) {
	# Last chance - try looking in equus directly

	$self->open_equus();
	my $ligation = 
	  Kill_Equus::equus_get_ligation_from_plate($self->{edi},
						    $self->{equus_db},
						    $plate);
	if ($ligation) {
	    $res = { ligation => "$ligation" };
	}
    }


    $self->add_cache(plate => $plate, $res);

    return $res;
}

sub get_sample_gel_file {
    my ($self, $sample) = @_;

    if (my $res = $self->check_cache(sample_gel_file => $sample)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select gf.gelfilename
				from   gelfile gf, seqread sr
				where  sr.name = ?
				and    gf.id_gel = sr.id_gel]);
    $sth->execute($sample);
    my ($gelfile) = $sth->fetchrow_array();
    $sth->finish();
    
    $self->add_cache(sample_gel_file => $sample, $gelfile);

    return $gelfile;
}

sub get_sample_gel_info {
    my ($self, $sample) = @_;

    if (my $res = $self->check_cache(sample_gel_info => $sample)) {
	return $res;
    }

    # Get id_gel

    my $sth1 = $self->prepare(qq[select sr.id_gel, sr.lane
				 from   seqread sr
				 where  sr.name = ?]);
    $sth1->execute($sample);
    my ($id_gel, $lane) = $sth1->fetchrow_array();
    $sth1->finish();

    unless ($id_gel) { return; }

    my $res;
    unless ($res = $self->check_cache(same_gel_info_id_gel => $id_gel)) {

	my $sth2 = $self->prepare(qq[select gf.gelfilename,
				            to_char(gf.abi_run_date,
						    'YYYY-MM-DD HH24:MI:SS')
				     from   gelfile gf
				     where  gf.id_gel = ?]);
	$sth2->execute($id_gel);
	my ($gelfile, $run_date) = $sth2->fetchrow_array();
	$sth2->finish();
	
	my $q3 =
	    qq[select sm.name, sm.type, smtd.description
	       from   seqmachine sm, seqmachinetypedict smtd
	       where smtd.id_dict = sm.type
	       and   sm.id_seqmachine in (select gq.id_seqmachine
					  from   gel_queue gq
					  where  gq.id_gel = ?
					  union
					  select sms.id_seqmachine
					  from   gel_machine gm,
					         seqmachine_slot sms
					  where  gm.id_gel = ?
					  and    gm.id_slot = sms.id_slot)];

	my $sth3 = $self->prepare($q3);
	$sth3->execute($id_gel, $id_gel);
	my ($machine_name, $machine_type, $machine_description)
	    = $sth3->fetchrow_array();
	$sth3->finish();

	$res = {
	    gelfile             => $gelfile,
	    run_date            => $run_date,
	    machine_name        => $machine_name,
	    machine_type        => $machine_type,
	    machine_description => $machine_description
	    
	};

	$self->add_cache(same_gel_info_id_gel => $id_gel, $res);
    }
    
    if ($res) {
	my %res2 = %$res;
	
	$res2{lane} = $lane;
	
	$self->add_cache(sample_gel_info => $sample, \%res2);
	return \%res2;
    }

    return;
}

sub get_loadingsample_info {
    my ($self, $sample) = @_;

    if (my $res = $self->check_cache(loadingsample => $sample)) {
	return $res;
    }

    my $sth
	= $self->prepare(qq[select lp.category, ls.id_dnaplatemap,
				   ls.id_scsp, ls.id_loadingsample
			    from   seqread sr, gel_sample gs,
				   loadingsample ls, loadingplate lp
			    where  sr.name             = ?
			    and    gs.id_gel           = sr.id_gel
			    and    gs.lane             = sr.lane
			    and    ls.id_loadingsample = gs.id_loadingsample
			    and    lp.id_loadingplate  = ls.id_loadingplate]);
    $sth->execute($sample);
    my $res = $self->fetchrow_hash($sth,
				   qw[category id_dnaplatemap
				      id_scsp id_loadingsample]);
    $sth->finish();

    if (defined($res) && defined($res->{id_loadingsample})) {

	# Check if this was a finish_request

	my $sth3
	    = $self->prepare(qq[select id_frequest
				from   request_map
				where  id_loadingsample = ?]);
	$sth3->execute($res->{id_loadingsample});
	my ($id_frequest) = $sth3->fetchrow_array();
	$sth3->finish();
	
	$res->{id_frequest} = $id_frequest;
    }

    if (defined($res)
	&& defined($res->{id_frequest})
	&& !defined($res->{id_scsp})) {

	# deal with finishing reads that went onto 377s

	my $sth2
	    = $self->prepare(qq[select fr.id_scsp
				from finish_request fr
				where fr.id_frequest = ?]);
	$sth2->execute($res->{id_frequest});
	my ($id_scsp) = $sth2->fetchrow_array();
	$sth2->finish();

	$res->{id_scsp} = $id_scsp;
    }

    $self->add_cache(loadingsample => $sample, $res);

    return $res;
}

sub get_chem_info {
    my ($self, $id_scsp) = @_;

    if (my $res = $self->check_cache(scsp => $id_scsp)) { return $res; }

    my $sth = $self->prepare(qq[select sc.is_primer, sc.is_pcr, sc.suffix,
				       ptv.is_fwd, ptv.primername, ds.name,
				       pt.sequence
				from   seqchemistry sc,
				       seqchem_seqprotocol scsp,
				       pt_vector ptv, dyeset ds, primer_type pt
				where  scsp.id_scsp  = ?
				and    sc.id_seqchem = scsp.id_seqchem
				and    ptv.id_ptv    = sc.id_ptv
				and    ds.id_dyeset  = sc.id_dyeset
				and    pt.primername = ptv.primername]);

    $sth->execute($id_scsp);
    my $res = $self->fetchrow_hash($sth, qw[is_primer is_pcr suffix
					    is_forward primername dyeset
					    primer_seq]);
    $sth->finish();

    $self->add_cache(scsp => $id_scsp, $res);

    return $res;
}

sub get_additive_info {
    my ($self, $read) = @_;

    if (my $res = $self->check_cache(additives => $read)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select a.description
				from seqread sr, gel_sample gs,
				     request_map rm, finish_request fr,
				     additive a
				where sr.name = ?
				and sr.id_gel = gs.id_gel
				and sr.lane = gs.lane
				and gs.id_loadingsample = rm.id_loadingsample
				and rm.id_frequest = fr.id_frequest
				and fr.id_additive = a.id_additive]);
    $sth->execute($read);
    my ($res) = $sth->fetchrow_array();

    $sth->finish();

    $self->add_cache(additives => $read, $res);

    return $res;
}

sub get_info_for_dnaplatemap {
    my ($self, $id_dnaplatemap) = @_;

    if (my $res = $self->check_cache(id_dnaplatemap => $id_dnaplatemap)) {
	return $res;
    }

    my $res;

    my $sth = $self->prepare(qq[select dpm.id_bbmap
				from   dnaplate_map dpm
				where  dpm.id_dnaplatemap = ?]);

    $sth->execute($id_dnaplatemap);
    my ($id_bbmap) = $sth->fetchrow_array();
    $sth->finish();
    
    if (defined($id_bbmap)) {
	$res = $self->get_info_for_bb_map($id_bbmap);
    }

    $self->add_cache(id_dnaplatemap => $id_dnaplatemap, $res);

    return $res;
}

sub map_retrans_template {
    my ($self, $plate, $maprow, $mapcol) = @_;

    my $key = "$plate $maprow $mapcol";

    if (my $res = $self->check_cache(retrans_template => $key)) {
	return $res;
    }

    my $is_original = $self->check_cache(bb_is_original => $plate);

    unless (defined($is_original)) {

	my $bb_sql = qq[select bb.is_original
			from   beckman_box bb
			where  bb.name    = ?];

	my $bb_sth = $self->prepare($bb_sql);
    
	$bb_sth->execute($plate);
	$is_original = $bb_sth->fetchrow_array();
	$bb_sth->finish();

	$self->add_cache(bb_is_original => $plate, $is_original);
    }

    unless (defined($is_original)) {
	# beckman_box entry doesn't exist - let's hope it's in equus :)

	my $res = [$plate, $maprow, $mapcol, 0];
	$self->add_cache(retrans_template => $key, $res);
	return $res;
    }

    if ($is_original) {
	my $res = [$plate, $maprow, $mapcol, 0];
	$self->add_cache(retrans_template => $key, $res);
	return $res;
    }

    my $or_sql = qq[select bb.name, rcm.maprow, rcm.mapcol
		    from   beckman_box bb, bb_map bbm, rowcol_map rcm
		    where  bb.id_beckmanbox = bbm.id_beckmanbox
		    and    bbm.id_map       = rcm.id_map
		    and    bb.is_original   = 1
		    and    bbm.id_subclone  in
		             (select bbm.id_subclone
			      from   bb_map bbm, beckman_box bb, rowcol_map rcm
			      where  bb.name    = ?
			      and    rcm.maprow = ?
			      and    rcm.mapcol = ?
			      and    bbm.id_map = rcm.id_map
			      and    bbm.id_beckmanbox = bb.id_beckmanbox)];

    my $or_sth = $self->prepare($or_sql);

    $or_sth->execute($plate, $maprow, $mapcol);
    my ($or_plate, $or_maprow, $or_mapcol) = $or_sth->fetchrow_array();
    $or_sth->finish();

    unless (defined($or_plate)) {
	return;
    }

    my $res = [$or_plate, $or_maprow, $or_mapcol, 1];
    $self->add_cache(retrans_template => $key, $res);
    return $res;
}

sub map_retrans_template_info {
    my ($self, $info) = @_;

    unless ($info) { return; }

    my $plate  = $info->{plate};
    my $maprow = $info->{maprow};
    my $mapcol = $info->{mapcol};

    my $res = $self->map_retrans_template($plate, $maprow, $mapcol);

    unless ($res) { return; }

    $info->{plate}               = $res->[0];
    $info->{maprow}              = $res->[1];
    $info->{mapcol}              = $res->[2];
    $info->{is_retransformation} = $res->[3];

    return $info;
}

sub get_info_for_bb_map {
    my ($self, $id_bbmap) = @_;

    if (my $res = $self->check_cache(id_bbmap => $id_bbmap)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select bb.name, rcm.maprow, rcm.mapcol,
				       sc.id_ligation, bbm.id_sourceplatemap
				from   bb_map bbm, beckman_box bb,
				       rowcol_map rcm, subclone sc
				where  bbm.id_bbmap       = ?
				and    bb.id_beckmanbox   = bbm.id_beckmanbox
				and    rcm.id_map         = bbm.id_map
				and    sc.id_subclone     = bbm.id_subclone]);

    $sth->execute($id_bbmap);

    my $res = $self->fetchrow_hash($sth, qw[plate maprow mapcol ligation
					    id_sourceplatemap]);
    $sth->finish();

    $res = $self->map_retrans_template_info($res);
    
    if ($res) {
	$res->{template} = sprintf('%s%s%02d',
				   $res->{plate},
				   $res->{maprow},
				   $res->{mapcol});


	if (defined($res->{id_sourceplatemap})) {

	    # Do source_plate stuff

	    my $sth2
		= $self->prepare(qq[select sp.platename, spm.samplename,
				           rcm.maprow, rcm.mapcol
				    from   source_plate sp,
				           sourceplate_map spm,
				           rowcol_map rcm
				    where  spm.id_sourceplatemap = ?
				    and    sp.id_sourceplate = spm.id_sourceplate
				    and    rcm.id_map = spm.id_map]);
	    $sth2->execute($res->{id_sourceplatemap});
	    my ($platename, $templatename, $maprow, $mapcol)
		= $sth2->fetchrow_array();
	    $sth2->finish();

	    if (defined($templatename)) {
		$res->{template} = $templatename;
		if (defined($platename)) {
		    $res->{plate}    = $platename;
		    $res->{maprow}   = $maprow;
		    $res->{mapcol}   = $mapcol;
		}
		
	    }
	}
    }

    $self->add_cache(id_bbmap => $id_bbmap, $res);
    
    return $res;
}

sub get_finish_request_info {
    my ($self, $id_frequest) = @_;

    if (my $res = $self->check_cache(id_frequest => $id_frequest)){
	return $res;
    }

    my $sth = $self->prepare(qq[select platename, rowletter, colnum, id_fbatch,
				       id_primer
				from   finish_request
				where  id_frequest = ?]);

    $sth->execute($id_frequest);
    my $res = $self->fetchrow_hash($sth,
				   qw[plate maprow mapcol
				      id_fbatch seq_primer]);
    $sth->finish();
    
    $res = $self->map_retrans_template_info($res);

    if (defined($res)) {

	$res->{type} = "template";
	$res->{template} = sprintf("%s%s%02d",
				   $res->{plate},
				   $res->{maprow},
				   $res->{mapcol});

	# Get project from finish_batch
	
	my $fbatch_info = $self->get_fbatch_info($res->{id_fbatch});
	if (defined($fbatch_info)) {
	    $res->{projectname} = $fbatch_info->{projectname};
	}

	# This handles PCR products off clones

	my $sth2 = $self->prepare(qq[select dna_source, lookup_type,
				            primer_1, primer_2,
				            id_pcrvessel, product_size_bp,
				            id_pcrproduct
				     from   pcr_product
				     where  pcr_template_name = ?]);

	$sth2->execute($res->{plate});
	my ($dna_source, $lookup_type, $pcr_primer1, $pcr_primer2,
	    $id_pcrvessel, $product_size_bp, $id_pcrproduct)
	    = $sth2->fetchrow_array();
	$sth2->finish();

	if (defined($lookup_type)) {
	    $self->lookup_pcr_dna_source($res, $dna_source, $lookup_type);
	    $res->{id_pcrvessel}    = $id_pcrvessel;
	    $res->{pcr_primer1}     = $pcr_primer1;
	    $res->{pcr_primer2}     = $pcr_primer2;
	    $res->{product_size_bp} = $product_size_bp;
	    $res->{pcr_type}        = $lookup_type;
	    $res->{id_pcr}          = $id_pcrproduct;
	    $res->{type} = "PCR";
	}
    }

    $self->add_cache(id_frequest => $id_frequest, $res);

    return $res;
}

sub lookup_pcr_dna_source {
    my ($self, $pcr_info, $dna_source, $lookup_type) = @_;

    if ($lookup_type == 1
	|| $lookup_type == 6
	|| $lookup_type == 7) {      # Clone or clone directed walk

	$pcr_info->{template} = $pcr_info->{plate};
	$pcr_info->{ligation} = $pcr_info->{plate};
	$pcr_info->{clone}    = $dna_source;
	$pcr_info->{source_type} = 'clone';

    } elsif ($lookup_type == 2
	     || $lookup_type == 4
	     || $lookup_type == 5) { # Subclone

	my $bbm_info = $self->get_info_for_bb_map($dna_source);

	if ($bbm_info) {

	    $pcr_info->{template} = $bbm_info->{template};
	    $pcr_info->{ligation} = $bbm_info->{ligation};
	    $pcr_info->{source_type} = 'template';

	} else {

	    $pcr_info->{template} = undef; # So caller knows we have failed...

	}

    } elsif ($lookup_type == 3) { # Genomic
	# print STDERR "********\n$pcr_info->{projectname}\n$dna_source\n";
	my $project = $pcr_info->{projectname};
	$pcr_info->{template} = $pcr_info->{plate};
	$pcr_info->{ligation} = $pcr_info->{plate};
	$pcr_info->{clone}    = $self->get_genomic_clone_for($dna_source,
							     $project);
	# print STDERR "$pcr_info->{clone}\n";
	$pcr_info->{project}  = $project;

	my $species = $self->get_species_for_project($dna_source);
	if (defined($species) && @$species == 1) {
	    $pcr_info->{organism} = $species->[0]->[0];
	}

	$pcr_info->{source_type} = 'genomic';

    } else {

	# Unknown type
	$pcr_info->{template} = undef; # So caller knows we have failed...

    }
}

sub get_genomic_clone_for {
    my ($self, $dna_source, $project) = @_;


    # This didn't work, as it's not possible to uniquely derive a clone
    # from a project, even if it's a WGS one.
#    my $sth = $self->prepare(qq[select c.clonename
#				from   clone c, clone_project cp
#				where  c.speciesname  = ?
#				and    cp.projectname = ?
#				and    c.clonename    = cp.clonename
#				and    c.clone_type   = 2]);
#    # clone_type 2 = whole-genome shotgun library
#
#    $sth->execute($dna_source, $project);
#    my @clones = $sth->fetchrow_arrayref();
#    $sth->finish();
#
#    if (@clones && $clones[0]) {
#	print STDERR "\@clones = @clones\n";
#	return $clones[0];
#    }

    return "${dna_source}_genomic_dna"; 
}

sub get_species_for_project {
    my ($self, $project) = @_;

    if (my $res = $self->check_cache(species_for_project => $project)) {
	return $res;
    }
    
    my $sth = $self->prepare(qq[select distinct speciesname
				from   clone_project cp, clone c
				where  cp.projectname = ?
				and    c.clonename = cp.clonename]);

    $sth->execute($project);
    my $res = $sth->fetchall_arrayref();
    $sth->finish();

    $self->add_cache(species_for_project => $project, $res);

    return $res;
}

sub get_fbatch_info {
    my ($self, $id_fbatch) = @_;

    if (my $res = $self->check_cache(id_fbatch => $id_fbatch)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select projectname
				from   finish_batch
				where  id_fbatch = ?]);

    $sth->execute($id_fbatch);

    my $res = $self->fetchrow_hash($sth, qw[projectname]);

    $sth->finish();

    $self->add_cache(id_fbatch => $id_fbatch, $res);

    return $res;
}

sub get_custom_primer_info {
    my ($self, $id_primer) = @_;

    if (my $res = $self->check_cache(id_primer => $id_primer)) {
	return $res;
    }

    my $sth = $self->prepare(qq[select primername, projectname, primerseq
				from   primer
				where  id_primer = ?]);
    $sth->execute($id_primer);
    
    my $res = $self->fetchrow_hash($sth, qw[primername projectname primerseq]);

    $sth->finish();

    $self->add_cache(id_primer => $id_primer, $res);

    return $res;
}

sub get_sourceplate_map_info {
    my ($self, $id_sourceplatemap) = @_;

    if (my $res = $self->check_cache(id_sourceplatemap => $id_sourceplatemap)){
	return $res;
    }

    my $sth = $self->prepare(qq[select spm.samplename, spm.id_sourceplate,
				       sp.format, sptd.description,
				       sp.platename, sp.id_source,
				       sp.id_ligation, sp.libraryname
				from   sourceplate_map spm,
				       source_plate sp,
				       sourceplatetypedict sptd
				where  spm.id_sourceplatemap = ?
				and    sp.id_sourceplate = spm.id_sourceplate
				and    sp.id_type = sptd.id_dict]);

    my @keys = qw[samplename id_sourceplate format description
		  platename id_source id_ligation libraryname];

    $sth->execute($id_sourceplatemap);
    my $res = $self->fetchrow_hash($sth, @keys);

    $sth->finish();
    $self->add_cache(id_sourceplatemap => $id_sourceplatemap, $res);

    return $res;
}

sub set_duplicated_asp_status {
    my ($self, $read) = @_;

    # NB ID_DICT for 'processed already' is 18

    my $sth = $self->prepare(qq[update seqread
				set    cm_status = 18
				where  name      = ?]);
    $sth->execute($read);
    $sth->finish();
}

sub get_viral_sample_info {
    my ($self, $clone) = @_;

    if (my $res = $self->check_cache(viral_pcr_pool => $clone)) {
	return $res;
    }

    my $poolinfo_query
	= qq[select dpc.id_derived_project, amp.id_amplimer,
	            amp.external_amplimer_id, amp.id_disease_fragment,
	            amp.primer1_seq, amp.primer2_seq, amp.size_bp,
	            df.fragment_name, dp.external_sample_id, dp.projectname
	     from   derived_project_clone dpc, amplimer amp,
	            disease_fragment df, derived_project dp
	     where  dpc.clonename = ?
	     and    amp.id_amplimer = dpc.id_amplimer
	     and    df.id_disease_fragment = amp.id_disease_fragment
	     and    dp.id_derived_project = dpc.id_derived_project];
    my $poolinfo_sth = $self->prepare($poolinfo_query);

    my @pooled_products;

    $poolinfo_sth->execute($clone);
    while (my ($id_derived_project, $id_amplimer, $ext_amplimer_name,
	       $id_disease_fragment, $primer1_seq, $primer2_seq, $size_bp,
	       $fragment_name, $ext_sample_id, $project)
	   = $poolinfo_sth->fetchrow_array()) {

	push(@pooled_products, {
	    id_amplimer       => $id_amplimer,
	    ext_amplimer_name => $ext_amplimer_name,
	    primer1           => $primer1_seq,
	    primer2           => $primer2_seq,
	    size_bp           => $size_bp,
	    id_fragment       => $id_disease_fragment,
	    fragment_name     => $fragment_name,
	    id_project        => $id_derived_project,
	    int_sample_name   => $project,
	    ext_sample_name   => $ext_sample_id,
	});
    }

    $poolinfo_sth->finish();

    $self->add_cache(viral_pcr_pool => $clone, \@pooled_products);

    return \@pooled_products;
}

1;
