#!/usr/local/bin/perl
#
# Usage: validate_clone.pl <clonename>
#
# Takes a clonename and produces a report showing all associated entities
# and whether or not they have the correct clonename (etc)
#

# Configuration ---------------------------------------------------------------

use strict;
use WrapDBI; # Sanger wrapper for the DBperl interface

my $dbh;
my $dbi_user = 'reports';	# DBI alias

my @dnaprep_ids;  # list of dnaprep.id_prep values for the specified clone
my @ligation_ids;  # list of ligation.id_ligation values for the specified clone
my @rdrequest_ids;  # list of rdrequest.id_rdrequest values for the specified clone

# Main ------------------------------------------------------------------------

my ($clonename) = @ARGV;

die "Please specify a clone name\n" unless $clonename;

eval {
	$dbh = WrapDBI->connect($dbi_user, {RaiseError => 1});

# check this clone name actually exists
	my $clonename_sth = $dbh->prepare(qq[select clonename from clone where clonename = ?]);

# check clone and project comments
	my $comment_sth = $dbh->prepare(qq[select a.remark, c.projectname,c.remark from 
		clone a, clone_project b, project c where 
		a.clonename = b.clonename and 
		b.projectname = c.projectname and 
		a.clonename = ?]);

# check if a project with the same name as the clone exists, and what clone it is linked to
	my $proj_link_sth = $dbh->prepare(qq[select clonename from clone_project where projectname = ?]);

# check if a project with the name of the clone exists
	my $proj_unlink_sth = $dbh->prepare(qq[select projectname from project where projectname = ?]);

# check auto name doesn't contain old clone name
	my $autoname_sth = $dbh->prepare(qq[select root,next_val from autoboxname where clonename = ?]);

# if this is sequenced externally, let them know
	my $extorg_sth = $dbh->prepare(qq[select b.orgtitle from clone_ext_seq a, organisation b 
		where a.id_org = b.id_org and a.clonename = ?]);

# check external name 
	my $extname_sth = $dbh->prepare(qq[select externalname from external_name where clonename = ?]);

# check correct name in dnaprep
	my $dnaprep_sth = $dbh->prepare(qq[select c.id_prep,c.clonename from 
		glystock a, clone_culture b, dnaprep c where
		a.id_glystock = b.id_glystock and
		b.id_culture = c.id_culture and 
		a.clonename = ?]);

# check clonename in ligation.
# (1) ligation could be from a SIL (and will not therefore backtrack through dnaprep)
	my $ligsil_sth = $dbh->prepare(qq[select e.id_ligation, e.clonename
		from sil_dnasource a, sil_request b, sil_job c, fragmentation_band d, ligation e
		where
		a.id_source = b.id_source and 
		b.id_request = c.id_request and
		c.id_frag = d.id_frag and
		d.id_fragband = e.id_fragband and
		a.clonename = ?]);

# (2) ligation could be routinely derived (non-SIL) 
# Use previously retrieved id_preps to shorten lookup
	my $lignorm_sth = $dbh->prepare(qq[select d.id_ligation,d.clonename
		from dnaprep a, dnaprep_frag b, fragmentation_band c, ligation d
		where
		a.id_prep = b.id_prep and 
		b.id_frag = c.id_frag and
		c.id_fragband = d.id_fragband and
		a.id_prep = ?]);

# check clonename in restriction digest requests
	my $rdrequest_sth = $dbh->prepare(qq[select id_rdrequest, clonename 
		from rdrequest where id_dnaprep = ?]);

# get beckmanbox IDs and id_bbmaps
	my $get_bb_sth = $dbh->prepare(qq[select c.id_beckmanbox,c.id_bbmap from 
		ligation a, subclone b, bb_map c where
		a.id_ligation = b.id_ligation and
		b.id_subclone = c.id_subclone and
		c.id_map = 1 and
		a.id_ligation = ?]);

# FOR EACH ID_BBMAP
	my $get_dp_sth = $dbh->prepare(qq[select id_dnaplate, id_dnaplatemap 
		from dnaplate_map where id_map = 1 and id_bbmap = ?]);

# loadingplate_status (plate must be category 1 - shotgun)
	my $get_lp_sth = $dbh->prepare(qq[select a.id_loadingplate from 
		loadingplate a, loadingsample b where 
		a.id_loadingplate = b.id_loadingplate and
		b.id_dnaplatemap = ? and
		a.category = 1]);


# so far, this checks clonename is in records where it should be.
# the following statements get all occurrences so we can check if it is present where it should not be

# gets all preps where this clonename is recorded
my $check_dnaprep_sth = $dbh->prepare(qq[select id_prep from dnaprep where clonename = ?]);

# gets all ligations where clonename is recorded
my $check_lig_sth = $dbh->prepare(qq[select id_ligation from ligation where clonename = ?]);

# gets the rdrequests where clonename is recorded
my $check_rdreq_sth = $dbh->prepare(qq[select id_rdrequest from rdrequest where clonename = ?]);




	$clonename_sth->execute($clonename);
	unless ($clonename_sth->fetchrow_array) {
		print "ERROR: A clone called $clonename was not found in the database\n";
	}
	print '-' x 79, "\n";
	print "Clone consistency report\n";
	print '-' x 79, "\n";
	print "Clonename: $clonename\n";
	
	$comment_sth->execute($clonename);
	my ($clone_remark,$projectname,$proj_remark) = ($comment_sth->fetchrow_array);
	if ($projectname) {
		print "Clone remark:\n $clone_remark\n";
		print "Project name $projectname\n";
		print "Project remark:\n $proj_remark\n";
	} else {
		print "WARNING: no project found linked to this clone\n";
		my ($linked_clonename) = $proj_link_sth->execute($clonename);
		if ($linked_clonename) {
			# Check if a project with the name of the clone exists (with clone_project entry)
			print "A project with this clonename ($clonename) has been found, linked to clone $linked_clonename\n";
		} else {
			# Check if a project with the name of the clone exists (no clone_project entry)
			my ($unlinked_clonename) = $proj_unlink_sth->execute($clonename);
			if ($unlinked_clonename) {
				print "A project with this clonename ($clonename) has been found. It is not linked to a clone entry\n";
			}
		}
	}
	$autoname_sth->execute($clonename);
	my ($root,$next_val) = ($autoname_sth->fetchrow_array);
	if ($root) {
		print "Next automatic plate name will be: $root-$next_val\n";
	}
	$extorg_sth->execute($clonename);
	my ($ext_org) = ($extorg_sth->fetchrow_array);
	
	if ($ext_org) {
		print "This clone is being sequenced in parallel with:\n";
		print "$ext_org\n";
		print "They need to be informed of any changes\n";
	}
	
	$extname_sth->execute($clonename);
	my ($ext_name) = ($extname_sth->fetchrow_array);
	print "This clone has an external name of : $ext_name\n";

	$dnaprep_sth->execute($clonename);
	while (my ($id_prep,$dnaprep_clonename) = ($dnaprep_sth->fetchrow_array)) {
		if ($clonename eq $dnaprep_clonename) {
			print "DNA prep $id_prep has clonename $dnaprep_clonename\n";
		} else {
			print "DNA prep $id_prep has clonename $dnaprep_clonename <<<<\n";
		}
		push(@dnaprep_ids,$id_prep);
	}
	
	$ligsil_sth->execute($clonename);
	while (my ($id_lig,$lig_clonename) = ($ligsil_sth->fetchrow_array)) {
		if ($clonename eq $lig_clonename) {
			print "SIL ligation $id_lig has clonename $lig_clonename\n";
		} else {
			print "SIL ligation $id_lig has clonename $lig_clonename <<<<\n";
		}
		push(@ligation_ids,$id_lig);
	}

	foreach my $dp_id(@dnaprep_ids) {
		$lignorm_sth->execute($dp_id);
		$rdrequest_sth->execute($dp_id);
		while (my ($id_lig,$lig_clonename) = ($lignorm_sth->fetchrow_array)) {
			if ($clonename eq $lig_clonename) {
				print "Standard ligation $id_lig has clonename $lig_clonename\n";
			} else {
				print "Standard ligation $id_lig has clonename $lig_clonename <<<<\n";
			}
			push(@ligation_ids,$id_lig);
		}
		while (my ($id_rdreq,$rd_clonename) = ($rdrequest_sth->fetchrow_array)) {
			if ($clonename eq $rd_clonename) {
				print "RD request $id_rdreq has clonename $rd_clonename\n";
			} else {
				print "RD request $id_rdreq has clonename $rd_clonename <<<<\n";
			}
			push(@rdrequest_ids,$id_rdreq);

		}
	}

	print '-' x 79, "\n";

	$check_dnaprep_sth->execute($clonename);
	while (my ($id_dp) = ($check_dnaprep_sth->fetchrow_array)) {
		my $found = 0;
		foreach(@dnaprep_ids) {
			if ($_ eq $id_dp) {$found = 1};
		}
		unless($found) {
			print "DNA prep $id_dp should not link to $clonename\n";
		}
	}
	
	$check_lig_sth->execute($clonename);
	while (my ($id_lig) = ($check_lig_sth->fetchrow_array)) {
		my $found = 0;
		foreach(@ligation_ids) {
			if ($_ eq $id_lig) {$found = 1};
		}
		unless($found) {
			print "Ligation $id_lig should not link to $clonename\n";
		}
	}

	$check_rdreq_sth->execute($clonename);
	while (my ($id_rdreq) = ($check_rdreq_sth->fetchrow_array)) {
		my $found = 0;
		foreach(@rdrequest_ids) {
			if ($_ eq $id_rdreq) {$found = 1};
		}
		unless($found) {
			print "RD request $id_rdreq should not link to $clonename (or dnaprep id not specified)\n";
		}
	}

	print '-' x 79, "\n";

	foreach my $id_lig (@ligation_ids) {
		$get_bb_sth->execute($id_lig);
		while (my($id_bb,$id_bbmap) = $get_bb_sth->fetchrow_array) {
			print "Beckman box $id_bb\n";
			$get_dp_sth->execute($id_bbmap);
			while (my($id_dp,$id_dpm) = $get_dp_sth->fetchrow_array) {
				print "\tDNA plate $id_dp\n";
				$get_lp_sth->execute($id_dpm);
				while (my ($id_lp) = $get_lp_sth->fetchrow_array) {
					print "\t\tShotgun loadingplate $id_lp\n";
				}
			}
		}
	}

	print '-' x 79, "\n";

# close all statement handles
	$proj_link_sth->finish;
	$proj_unlink_sth->finish;
	$clonename_sth->finish;
	$comment_sth->finish;
	$autoname_sth->finish;
	$extorg_sth->finish;
	$extname_sth->finish;
	$dnaprep_sth->finish;
	$ligsil_sth->finish;
	$lignorm_sth->finish;
	$rdrequest_sth->finish;
	$check_dnaprep_sth->finish;
	$check_lig_sth->finish;
	$check_rdreq_sth->finish;
};

if ($@) {
    if ($DBI::err) {
		print "ERROR: $DBI::errstr\n";
    } else {
		print "ERROR: $@\n";
	}
	print "If this recurs please contact bug, including the preceding error message.\n";
}

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

