# 
# GRL hereby grants permission to use, copy, modify and distribute    # 
# this software and its documentation for non-commercial purposes     # 
# without fee at the user's own risk on the basis set out below.      #
# GRL neither undertakes nor accepts any duty whether contractual or  # 
# otherwise in connection with the software, its use or the use of    # 
# any derivative, and makes no representations or warranties, express #
# or implied, concerning the software, its suitability, fitness for   #
# a particular purpose or non-infringement.                           #
# In no event shall the authors of the software or GRL be responsible # 
# or liable for any loss or damage whatsoever arising in any way      # 
# directly or indirectly out of the use of this software or its       # 
# derivatives, even if advised of the possibility of such damage.     #
# Our software can be freely distributed under the conditions set out # 
# above, and must contain this copyright notice.                      #
#######################################################################
#
# Author: pjm
# Description;
# 
# Allows a subcloner who has been assigned a batch of clones to get
# ligation numbers for each one. It will print a sheet out at the end
# listing each lig num against clone name. They can then write the blue
# & clear on the sheet before they enter the values using 
# 'Update Ligation Scores'
#
# $Id: LemurEnterBatchOfLigs.pm,v 1.47 2005/02/11 12:15:52 rmd Exp $
#

package LemurEnterBatchOfLigs;

require Exporter;

use     strict;
use     WrapDBI;
use     Mail;

use     Tk;

use TempFiles;
use Sys::Hostname;
use EquusDatabaseInterface;
use ChoosePrinter;
use Barcode;
use Benchmark;

use Data::Dumper;


#########################################
# The old BrowseEntry.pm doesn't support
# deletes. Let's try the new one inststuead
#########################################

require NewBrowseEntry;


#my $dbuser = 'dev2';                      # for testing purposes only

##########################################
# CONSTANTS
# i use emacs - leave space after '\' char
# so colour parser works!
##########################################

*MAIN::BITMAP_DIR      = \ "$ENV{'BADGER'}/lib/finch/bitmaps";
*MAIN::EQUUS_TEMP_DIR  = \ '/nfs/sids/equus/tmp_files/';

##########################################
# GLOBALS
# to this namespace i hope...
##########################################


my $debug = 0;


my %recoveryMethodHash;   # quick look up so only one access to database needed


my %fragMethodHash;       # Different Fragmentation methods
my %fragSizeHash;         # Each values from abouve Hash has array entry here
                          # for possible frag sizes.
#my %operatorHash;

my @bandsRecovered;

my @ligationNum;


################################################################################
# create Fragment & Ligation  window.
#
# args;
#      $type               type of this object
#      $parentWindow       guess...
#      $requested_db_user  example - 'dev1'
#      $new_batch          true or false value
#      $session_id         a session number created when Library Menu started
################################################################################

sub new {
    my ($type,
	$parentWindow,
	$requested_db_user,
	$new_batch,
	$session_id,
        $pathogen_mode)        = @_;
    my $dbUser;


    if( defined($requested_db_user) && ($requested_db_user eq '') ) {
	$dbUser = 'dev1'  # safe default
    }
    else {
	$dbUser = $requested_db_user;
    }

    my $realUserName = getpwuid($<);

    my $self = {
        dbUser        => $dbUser,
        newBatch      => $new_batch,
        session_id    => $session_id,
        realUserName  => "$realUserName",
        pathogen_mode => $pathogen_mode
    };

    bless($self, $type);

    my @localtime       = localtime;
    $self->{todaysDate} =  $localtime[3]."/".
	                  ($localtime[4] + 1)."/".
	                  ($localtime[5] + 1900);

    my $month = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
                 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec')[$localtime[4] + 1];

    # this was used on slice lables labels
    $self->{todaysMonthYear} = $month."-".($localtime[5] + 1900);

    # set up hash tables, so do all DB access in one. Only one connection
    # is made.

    $self->setupHashTables();
    $self->prepare_sql();
    $self->createWindow($parentWindow);

    return $self;
}

#
# if $new_batch equals true, it will not display
#

sub createWindow {
    my ($self, $parentWindow) = @_;
 
    
    $self->{mw} = $parentWindow->Toplevel();
#######################################################
#	$self->{mw}->wm('minsize', 370, 650); 
#    	$self->{mw}->wm('maxsize', 370, 650);
#######################################################  
    
    my $mw = $self->{mw};

    # batch or job is old code - to be removed

    my $dataType = "Batch";
    my ($text,$height);

    if( $self->{newBatch} ) {
	$self->{mw}->title("New $dataType Details");

	$text   = "Enter New $dataType of Ligations";
	$height = 1;
    }
    else {
	$self->{mw}->title("Append Details to Existing $dataType");

	$text   = "Append Details to an\nExisting $dataType of Ligations";
	$height = 2;
    }

    $self->{mw}->Label(width => 30)->pack;

    my $b = 
	$mw->Button(-font        => '*-times-bold-r-normal--*-180-*-*-p-*-*-*',
		    -text        => $text,
		    -height      => $height,
		    -bg          => 'white',
		    -relief      => 'groove',
		    -borderwidth => '3',
		    )->pack(-side => 'top');

    $b->bindtags(['EggButton',$b->toplevel,'all']);
    $b->bind('EggButton', '<Control-Button-2>', sub{ 
	warn "\$debug was $debug, setting to 1\n";
	$debug = 1;
    });


    $self->{mw}->Label()->pack;
 
    $self->{holderF}     = $self->{mw}->Frame();

    my $batchF = $self->{holderF}->Frame(-relief => 'raised');
    $self->createBatchFrame($batchF);


#    $self->{cloneF}      = $self->{holderF}->Frame(-relief      => 'raised');
    $self->{experimentF} = $self->{holderF}->Frame(-relief      => 'raised');
    $self->{bandsF}      = $self->{holderF}->Frame(-relief      => 'groove');
    $self->{ligationF}   = $self->{holderF}->Frame(-relief      => 'raised');

    # fill the 4 frames/tabs with widgets.

#    $self->createCloneFrame(     $self->{cloneF}     );
    $self->createExperimentFrame($self->{experimentF});
    $self->createBandsFrame(     $self->{bandsF}     );
    $self->createLigationFrame(  $self->{ligationF}  );

    # Add Ok and Cancel buttons - dummy lable used to create space above
    # buttons.

    my $buttF    = $self->{mw}->Frame(-relief => 'groove');

#    $buttF->Label(-height=>1)->grid(-row    => 3,
#				    -column => 1,
#				    -sticky => 'nw');

    my $okAndNextFrame = $buttF->Frame(-relief      => 'groove');

    $okAndNextFrame->Button(-width    => 10,
			    -text     => 'Finished',
			    -command  => sub{
				return unless $self->finished();
				$self->{dbi}->disconnect if $self->{dbi};
				$self->{mw}->destroy;
			    },
			    )->pack( -side => 'left');
 
    $okAndNextFrame->Label(-width    => 10)->pack(-side => 'right');

    $okAndNextFrame->grid(-row    => 4,
			  -column => 0,
			  -sticky => 'nw');

    $buttF->Button(-width    => 10,
		   -text     => 'Cancel',
		   -command => \ sub {
		       $self->{dbi}->rollback   if $self->{dbi};
		       $self->{dbi}->disconnect if $self->{dbi};
		       $self->{mw}->destroy;
		   }
		   )->grid(-row    => 4,
			   -column => 2,
			   -sticky => 'ne');


    if( defined($batchF) ) {
	$batchF->pack(-side => 'top', # -anchor => 'nw'
		      );
    }

#    $self->{cloneF}->pack     (-side => 'top', -anchor => 'n');
    $self->{ligationF}->pack  (-side => 'top', -anchor => 'n');
    $self->{experimentF}->pack(-side => 'top', -anchor => 'n');
    $self->{bandsF}->pack     (-side => 'top', -anchor => 'n');

    $self->{holderF}->pack(-side  => 'top',
			   -padx  => 10,
			   -pady  => 5,
			   -ipadx => 5);

    $buttF->pack();#-side => 'bottom');

    my $feedbackF = $mw->Frame();
    $feedbackF->Label(-width        => 46,
                      -relief       => 'sunken',
                      -anchor       => 'w',
                      -textvariable => \$self->{feed_back}
                      )->pack();
    $feedbackF->pack(-side => 'bottom');
}

sub set_feed_back {
    my ($self, $message) = @_;

    $self->{feed_back} = $message;
    $self->{mw}->update();
}

################################################################################
#
################################################################################

sub createBatchFrame {

    my ($self, $bF) = @_;

    # Vector

    my $vector_enzyme_list = $self->getVectorList();

    $bF->Label(
	       -text   => 'Vector', 
	       -anchor => 'w'
	       )->grid(-row    => 1,
		       -column => 1,
		       -sticky => 'nw');

    $bF->BrowseEntry(-width     => 18,
		     -relief    => 'sunken',
		     -variable  => \$self->{pickedVector},
		     -choices   => $vector_enzyme_list,
		     -state     => 'readonly',
		     -browsecmd => sub {
			 shift;
			 $self->getLigBatchNow(shift) if $self->{newBatch};
		     },
		     )->grid(-row    => 1, 
			     -column => 2, 
			     -sticky => 'nw');

    # Batch ID - only show if entering details for an old batch.

    unless( $self->{newBatch} ) {

	$bF->Label(
		   -text   => 'Batch No.', 
		   )->grid(-row    => 2,
			   -column => 1,
			   -sticky => 'nw');

	$self->{batchIDWidget} =
	    $bF->BrowseEntry(-width     => 10,
			     -relief    => 'sunken',
			     -variable  => #\$self->{pickedBatchID},
			         \$self->{ligBatch},
			     -browsecmd => sub {
				 shift;
				 $self->{id_ligbatch}->{$self->{pickedVector}} =
				     shift;
			     },
			     )->grid(-row    => 2, 
				     -column => 2, 
				     -sticky => 'nw');

	$self->{batchIDWidget}->bind('<KeyPress-Return>', sub {
	    $self->searchLigBatchNow($self->{ligBatch});} );
    }
    else {
	$bF->Label(-text  => 'Batch No. ',
		   )->grid(-row    => 2,
			   -column => 1,);
	$bF->Label(-textvariable  => \$self->{batchNumberToSee},
		   )->grid(-row    => 2,
			   -column => 2,);
    }
}

################################################################################
# createExperimentFrame
#
# Arguments;
#           experimentF  - Frame to put gadgets in
################################################################################

sub createExperimentFrame {

    my ($self, $experimentF) = @_;
    my $temp;  # ASSIGNED BrowseEntry WIDGETS SO CAN DO INSERTS

    my $ef = $experimentF->Frame(-relief => 'groove', -borderwidth => '3');

    # Frag method

    $ef->Label (#-width  => 16,
		-height => 1,
		-text   => 'Fragmentation',
		-anchor => 'w'
		)->grid(-row    => 2,
			-column => 1,
			-sticky => 'nw');

    $ef->BrowseEntry(-variable  => \$self->{fragMethod},
		     -width     => 18,
		     -state     => 'readonly',
		     -browsecmd => sub {
			 $self->changeFragMethod;
		     },
		     -choices   => [keys %fragMethodHash]
		     )->grid(-row    => 2,
			     -column => 2,
			     -sticky => 'nw');

    if( $fragMethodHash{Sonication} ) {
	$self->{fragMethod} = 'Sonication';  # default frag method
    }

    # Recovery Method

    $ef->Label (# -width  => 16,
		-text   => 'Recovery',
		-anchor => 'w'
		)->grid(-row    => 3,
			-column => 1,
			-sticky => 'nw');

    $ef->BrowseEntry(-variable  =>  \$self->{recoveryMethod},
		     -width     => 18,
		     -state     => 'readonly',
		     -choices   => [ sort keys %recoveryMethodHash ]
		     )->grid(-row    => 3,
			     -column => 2,
			     -sticky => 'nw');

    if( $recoveryMethodHash{"Agarace and Phenol"} ) {
	$self->{recoveryMethod} = "Agarace and Phenol"; #default recovery method
    }

    # was Restriction Disgest / Enzyme at  ** 4,2 **

    # Operator

    $ef->Label (# -width  => 16,
		-text   => 'Operator', 
		-anchor => 'w'
		)->grid(-row    => 5,
			-column => 1,
			-sticky => 'nw');

    $temp = $ef->BrowseEntry(-variable  => \$self->{operator},
			     -width     => 18,
			     -state     => 'readonly',
			     -choices   => [sort keys %{$self->{operatorHash}}],
			     )->grid(-row    => 5,
				     -column => 2);

    # Date Done. Get todays date from localtime and put into dd/mm/yyyy format

    $self->{dateDone} = $self->{todaysDate};

    $ef->Label (# -width  => 16,
		-text   => 'Date Done',
		-anchor => 'w'
		)->grid(-row    => 6,
			-column => 1,
			-sticky => 'nw');

    my $e = $ef->Entry(-width        => 17,
		       -relief       => 'sunken',
		       -bg           => 'lemonchiffon2',
		       -textvariable => \$self->{dateDone},
		       )->grid(-row    => 6,
			       -column => 2,
			       -padx   => 6,
			       -sticky => 'nw');

    $e->bind('<KeyPress-Return>', \ sub { 
	$self->isGoodDateEntered;
    } );

    $ef->grid(-row    => 1,
	      -column => 1,
	      -pady   => 5,
	      -ipady  => 10);
}


################################################################################
# createBandsFrame
#
# Arguments;
#           bandsF  - Frame to put gadgets in
################################################################################

sub createBandsFrame {

    my ($self, $bandsF)   = @_;
    my $variableBandSizeF = $bandsF->Frame(-relief => 'groove',
					   -borderwidth => '3');
    my $gadget;

    $self->{variableBandUsed} = 0;

    # @fromToArray is a 2D array for the Entry gadgets. Starts at [1][0]
    # for row 1, not [0][0].

    my @fromToArray;
    $self->{variableBandsArray} = \@fromToArray;

    $variableBandSizeF->Label (-width  => 5,
			       -text   => 'From',
			       -anchor => 'w',
			       )->grid(-row    => 0,
				       -column => 2,);

    $variableBandSizeF->Label (-width  => 5,
			       -text   => ' To ',
			       )->grid(-row    => 0,
				       -column => 3);


    $variableBandSizeF->Label (-width  => 8,
			       -text   => 'Used',
			       )->grid(-row    => 0,
				       -column => 4);

    foreach my $x ( 1..4 ) {
	$variableBandSizeF->Label (-width  => 14,
				   -text   => "Band $x",
				   -anchor => 'w',
				   )->grid(-row    => $x,
					   -column => 1,
					   -sticky => 'nw');
    
	$gadget = $variableBandSizeF->Entry(-width    => 5,
					    -relief   => 'sunken',
					    -bg       => 'lemonchiffon2',
					    -textvariable =>
					        \$fromToArray[$x][0],
					    )->grid(-row    => $x,
						    -column => 2,
						    -sticky => 'nw');

	$gadget = $variableBandSizeF->Entry(-width    => 5,
					    -relief   => 'sunken',
					    -bg       => 'lemonchiffon2',
					    -textvariable =>
					        \$fromToArray[$x][1],
					    )->grid(-row    => $x,
						    -column => 3,
						    -sticky => 'nw',
						    -padx   => 6);

	$variableBandSizeF->Radiobutton(#-width    => 2,
					-variable => \$self->{variableBandUsed},
					-value    => $x,
					)->grid(-row    => $x,
						-column => 4,
						-padx   => 6);
    }

    # get and set band sizes (i.e for sonication)
    $self->changeFragMethod;

    # DUMMY label

    $variableBandSizeF->Label()->grid(-row    => 5,
				      -column => 1,
				      -sticky => 'nw');

    $variableBandSizeF->Label (-text   => 'Frag Box',
			       -anchor => 'nw'
			       )->grid(-row    => 7,
				       -column => 1,
				       -sticky => 'nw');

    $variableBandSizeF->Entry(-width    => 12,
			      -relief   => 'sunken',
			      -bg       => 'lemonchiffon2',
			      -textvariable => \$self->{fragBox},
			      )->grid(-row    => 7,
				      -column => 2,
				      -sticky => 'nw',
				      -columnspan => 2);

    $variableBandSizeF->grid(-row    => 1,
			     -column => 1,
			     -pady   => 5,
			     -ipady  => 10);
}


################################################################################
# createLigationFrame
#
# Arguments;
#           ligationF  - Frame to put gadgets in
################################################################################

sub createLigationFrame {

    my ($self, $ligationF) = @_;

    my $vf = $ligationF->Frame(-relief      => 'groove',
			       -borderwidth => 3);

    my $row = 1;

    $vf->Label(-width  => 14,
	       -text   => 'Last Clone', 
	       -anchor => 'w'
	       )->grid(-row    => $row,
		       -column => 0,
		       -sticky => 'nw'); 

    $vf->Label(-width        => 17,
               -textvariable => \$self->{last_clone_entered},
	       -anchor       => 'w'
	       )->grid(-row    => $row,
		       -column => 1, );
    ++$row;

    $vf->Label(-width  => 14,
	       -text   => 'Clone Name', 
	       -anchor => 'w'
	       )->grid(-row    => $row,
		       -column => 0,
		       -sticky => 'nw');

    $self->{searchWidget} =
	$vf->BrowseEntry(-width     => 18,
			 -relief    => 'sunken',
			 -variable  => \$self->{cloneName},
			 -browsecmd => sub {
			     $self->cloneNameEntered();

			     $self->{picked} = 1;
			 },
			 )->grid(-row    => $row, 
				 -column => 1, 
				 -sticky => 'nw');

    $self->{searchWidget}->bind('<KeyPress-Return>', sub {
	$self->{picked} = 0;
	$self->searchForCloneName;
    });
    $self->{searchWidget}->bind('<KeyPress-Tab>', sub {
	$self->{picked} = 0;
	$self->searchForCloneName;
    });
    $self->{searchWidget}->bind('<FocusOut>', sub {

	return if $self->{picked} == 0; # user has to choose clone from list

	LemurUtils->setWait([$self->{mw}]);

	my ($dbh)  = $self->{dbi};

	eval {
            $dbh = $self->connect_to_oracle();

	    if( ! $self->checkCloneName($self->{cloneName}, $dbh) ){
		LemurUtils->showError($self->{mw},
				      "The Clone '$self->{cloneName}' does ".
				      "not exist in the database.");
	    }
	};
	
	if ($@) {
	    $self->expire("$@ : in ");
	}

	LemurUtils->unSetWait([$self->{mw}]);
    });
    

    # DNA Prep used
    ++$row;

    $vf->Label (-width  => 14,
		-text   => 'DNA Prep Used',
		-anchor => 'w'
		)->grid(-row    => $row,
			-column => 0,
			    -sticky => 'nw');
    
    $self->{DNAPrepNumWidget} = 
	$vf->BrowseEntry(-width     => 18,
			 -variable  => \$self->{DNAPrepNum}, 
			 -state     => 'readonly',
			 )->grid(-row    => $row,
				 -column => 1,
				 -sticky => 'nw');
    # Fragment volume used
    ++$row;

    $vf->Label (-width  => 16,
		-text   => 'DNA Vol used', 
		-anchor => 'nw'
		)->grid(-row    => $row,
			-column => 0, 
                        -sticky => 'nw');
    $vf->Entry(-width        => 20,
	       -relief       => 'sunken',
	       -bg           => 'lemonchiffon2',
	       -textvariable => \$self->{volumeUsed}
	       )->grid(-row    => $row,
		       -column => 1,);

    # Next Clone Button
    ++$row;

    $vf->Button(-width   => 16,
		-text    => 'Next Clone', 
		-command => sub{ $self->addNextClone() },
		)->grid(-row        => $row,  
			-column     => 0, 
			-columnspan => 2);

    $vf->pack(-side => 'bottom', -padx => 10, -pady => 5);  # ligation frame
}


################################################################################
# try to be nice to the sub-cloners who always do M13 and pUC's - put
# these 2 vectors at the top of the list (if the exist).
################################################################################

sub getVectorList {

    my ($self)         = @_;
    my (@vector_list)  = sort keys %{$self->{vectorsWithEnzymes}};

    my $x = 0;

    foreach (@vector_list) {
	if( $_ eq 'm13mp18 (SmaI)' ) {
	    my $temp = splice(@vector_list, $x, 1);
	    unshift(@vector_list, $temp);
	    last;
	}
	++$x;
    }

    $x = 0;

    foreach (@vector_list) {
	if( $_ eq 'puc18 (SmaI)' ) {
	    my $temp = splice(@vector_list, $x, 1);
	    unshift(@vector_list, $temp);
	    last;
	}
	++$x;
    }

    return \@vector_list;
}

sub connect_to_oracle {
    my ($self) = @_;
    my ($dbh)  = $self->{dbi};

    unless ($dbh) {
        $dbh         = WrapDBI->connect($self->{dbUser}, {RaiseError => 1});
        $self->{dbi} = $dbh;
    }

    if( !defined $dbh ) {
        $self->{dbi} = '';
        $self->expire("Could not connect to database") ;
    }

    $dbh->{AutoCommit} = 0;

    return $dbh;
}

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

    my $dbh = $self->connect_to_oracle();

    $self->{cache}->{sql}->{get_id_prep} =
        $dbh->prepare(q[select ID_PREP
                        from   DNAPREP
                        where  CLONENAME   = ?
                        and    PREP_NUMBER = ? ]);

    $self->{cache}->{sql}->{get_id_frag} =
        $dbh->prepare(q[select dpf.ID_FRAG, f.VOL_USED
                        from   DNAPREP_FRAG dpf, FRAGMENTATION f
                        where  dpf.ID_PREP       = ?
                        and    dpf.ID_FRAG       = f.ID_FRAG
                        and    f.RECOVERY_METHOD = ?
                        and    f.FRAG_METHOD     = ?
                        and    f.OPERATOR        = ? ]);

    $self->{cache}->{sql}->{update_vol_used} =
        $dbh->prepare(q[update FRAGMENTATION
                         set    VOL_USED = ?
                         where  ID_FRAG  = ? ]);

    $self->{cache}->{sql}->{insert_fragmentation} =
        $dbh->prepare(q[insert into FRAGMENTATION
                               (ID_FRAG,
                                RECOVERY_METHOD,
                                FRAG_METHOD,
                                OPERATOR,
                                VOL_USED)
                        values (?, ?, ?, ?, ?) ]);

    $self->{cache}->{sql}->{insert_dnaprep_frag} =
        $dbh->prepare(q[insert into DNAPREP_FRAG
                               (ID_PREP, ID_FRAG)
                        values (?, ?) ]);

}

################################################################################
# connects to DB and handles any errors. Calls various subroutines to setup
# hash tables with data from dictionaries.
################################################################################

sub setupHashTables {
    my ($self) = @_;
    my ($dbh);

    eval {
        my $timer1 = new Benchmark();

        $dbh = $self->connect_to_oracle();

        my $timer2 = new Benchmark();

	$self->getRecoveryMethods   ($dbh);
        my $timer3 = new Benchmark();

	$self->getFragMethods       ($dbh);
        my $timer4 = new Benchmark();

	$self->getOperators         ($dbh);
        my $timer5 = new Benchmark();

#	$self->getVectors           ($dbh);
        my $timer6 = new Benchmark();

	$self->getVectorsWithEnzymes($dbh);
        my $timer7 = new Benchmark();

        if( $debug ){
            $self->print_diff($timer2, $timer1, "Connected            ");
            $self->print_diff($timer3, $timer2, "getRecoveryMethods   ");
            $self->print_diff($timer4, $timer3, "getFragMethods       ");
            $self->print_diff($timer5, $timer4, "getOperators         ");
            $self->print_diff($timer6, $timer5, "getVectors           ");
            $self->print_diff($timer7, $timer6, "getVectorsWithEnzymes");
            $self->print_diff($timer7, $timer1, "Setup all hashes     ");
        }
    };

    if ($@) {
	$self->expire("$@ : Occured in setupHashtables()");
    }
}

sub print_diff {
    my ($self, $timer2, $timer1, $text) = @_;

    my $diff   = timediff($timer2, $timer1);
    print "$text - it took ", timestr($diff), "\n";
    
}

################################################################################
# setup  '%recoveryMethodHash'
################################################################################

sub getRecoveryMethods {

    my ($self, $dbh, $args) = @_;
    my ($arrayOfArrays, $arrayRef);

    $arrayOfArrays = $dbh->fetch_all(
        "select ID_DICT, DESCRIPTION
         from   FragRecoveryDict");

    foreach $arrayRef (@$arrayOfArrays) {
	$recoveryMethodHash{@$arrayRef[1]} = @$arrayRef[0];
    }
}


################################################################################
# setup '%fragMethodHash'
#        %FragSizeDict      (hash to a list)
################################################################################

sub getFragMethods {

    my ($self, $dbh, $args) = @_;
    my ($arrayOfArrays, $arrayRef);;


    ############# 
    # NEW
    ############

    $arrayOfArrays =
        $dbh->fetch_all(q[SELECT fmd.id_dict, fmd.description, 
                                 fsd.SIZE_FROM_KB, fsd.SIZE_TO_KB
                          FROM   fragmethoddict fmd, fragsizedict fsd
                          WHERE  fmd.id_dict = fsd.id_fragmethod (+)
                          ORDER BY fmd.id_dict, fsd.SIZE_FROM_KB,
                                   fsd.SIZE_TO_KB ]);

    my $method = $arrayOfArrays->[0]->[1];
    my @temp;

    foreach $arrayRef (@{$arrayOfArrays}) {
	$fragMethodHash{$arrayRef->[1]} = $arrayRef->[0];

        if( $method eq $arrayRef->[1] ){
            push @temp, "$arrayRef->[2] - $arrayRef->[3]";
        }
        else {
            $fragSizeHash{$method} = [@temp];
            @temp = ();
            $method = $arrayRef->[1];
            push @temp, "$arrayRef->[2] - $arrayRef->[3]";
        }
    }

    $fragSizeHash{$method} = [@temp];

    #
    return;
    #


    ############# 
    # OLD
    ############

    $arrayOfArrays = $dbh->fetch_all(
        "select ID_DICT, DESCRIPTION
         from   FragMethodDict");

    foreach $arrayRef (@$arrayOfArrays) {
	$fragMethodHash{@$arrayRef[1]} = @$arrayRef[0];
    }

    my $sth1 = $dbh->prepare(q[select SIZE_FROM_KB, SIZE_TO_KB
                               from   FragSizeDict
                               where  ID_FragMethod = ? ]);

    foreach my $method (keys %fragMethodHash) {

	my @temp;

#	$arrayOfArrays = $dbh->fetch_all(
#	    "select SIZE_FROM_KB, SIZE_TO_KB
#             from   FragSizeDict
#             where  ID_FragMethod = $fragMethodHash{$method}");

        $sth1->execute($fragMethodHash{$method});
        $arrayOfArrays = $sth1->fetchall_arrayref();

	foreach my $row (@$arrayOfArrays) {
	    push @temp, "@$row[0] - @$row[1]";
	}

	$fragSizeHash{$method} = \@temp;
    }
}


################################################################################
# setup '%operatorHash'
# if the users name matches the email address of someone in this team
# it sets the operator value to that person.
################################################################################

sub getOperators {

    my ($self, $dbh) = @_;
    my ($arrayOfArrays, $arrayRef);
    my %operatorHash;

    $arrayOfArrays =
        $dbh->fetch_all(q[SELECT tpr.ID_ROLE, 
                                 p.FORENAME, p.SURNAME, p.EMAIL
                          FROM   PERSON p, TEAM_PERSON_ROLE tpr
                          WHERE  tpr.ID_PERSON = p.ID_PERSON
                          AND    tpr.ROLETYPE  = 'Subcloning'
                          AND    tpr.ISCURRENT = 1
                          AND    p.iscurrent   = 1]); 
 
    foreach $arrayRef (@$arrayOfArrays) {
	$operatorHash{(@$arrayRef[1]." ".@$arrayRef[2])} = @$arrayRef[0];

	if($self->{realUserName} eq @$arrayRef[3]) {
	    $self->{operator} = @$arrayRef[1]." ".@$arrayRef[2];
	}
    }

    $self->{operatorHash} = \%operatorHash;
}


################################################################################
# setup %vectorHash
################################################################################

sub getVectors {

    my ($self, $dbh) = @_;
    my ($arrayOfArrays, $arrayRef);
    my ($arrayOfArraysLigNum, $arrayRefLigNum);
    my %vectors;

    $arrayOfArrays = $dbh->fetch_all(
         "select VECTORNAME
          from   VECTOR"); 
 
    foreach $arrayRef (@$arrayOfArrays) {

	$arrayOfArraysLigNum = $dbh->fetch_all("
           select ID_LIGBATCH
           from   LIGATION_BATCH, VECTORSITE
           where  SEQ_VECTOR            = ID_VECTORSITE
           and    VECTORSITE.VECTORNAME = '@$arrayRef[0]'"); 

	my @ligNumArray;

	foreach $arrayRefLigNum (@$arrayOfArraysLigNum) {
	    push @ligNumArray, @$arrayRefLigNum[0];
	}

	$vectors{@$arrayRef[0]} = \@ligNumArray;
    }

    $self->{vectors} = \%vectors;
}


################################################################################
# Checks the clone name is valid and populate the DNA Prep Number field
# in the experiment frame.
#
# Bound to <Return> key press on Clone Entry widget.
# Also called when clone name picked off the Search BrowseEntry widget in the 
# clone frame to populate the DNAPrepNumWidget.
################################################################################

sub cloneNameEntered {
    my ($self)    = @_;
    my $cloneName = $self->{cloneName};

    my $goodCloneName = 1;
    my $arrayOfArrays;


    if( $cloneName eq '' ) {
	return;
    }

    LemurUtils->setWait([$self->{mw}]);

    my $dbh;

    eval {
        $dbh = $self->connect_to_oracle();

        # the clone may have been cancelled by the finger printers. Check

        if( LemurUtils->is_project_cancelled( $dbh, $cloneName ) ){

	    LemurUtils->showError($self->{mw},
				  "This project is now cancelled. ".
				  "If you are sure you need a ligation ".
				  "number please see bug" );
            
            $self->{DNAPrepNum} = '';
            $self->{DNAPrepNumWidget}->delete(0.1, 'end');

            LemurUtils->unSetWait([$self->{mw}]);

            return;
        }

	# populate DNA prep widget with correct numbers (1,2 say).
        # Make it so 'super users' can enter a ligation even if it hasn't been
        # assigned to a subcloner (prep status 15).
        #
        my @super_users  = ('pjm', 'mcj', 'mq1', 'dw1', 'bt1', 'mng', 'shp');
        my $not_assigned = '';

        if( grep /^$self->{realUserName}$/, @super_users ){
            $not_assigned = ', 7';
        }

	$arrayOfArrays =
            $dbh->fetch_all(qq[
                               select dp.PREP_NUMBER
                               from   DNAPREP dp, DNAPREP_STATUS dps
                               where  dp.CLONENAME  = '$cloneName'
                               and    dp.ID_PREP    = dps.ID_PREP
                               and    dps.ISCURRENT = 1
                               and    dps.STATUS    in (15, 20 $not_assigned)
                               order by PREP_NUMBER ]);
        
	$self->{DNAPrepNum} = '';
	$self->{DNAPrepNumWidget}->delete(0.1, 'end');

        # no preps found
	if( scalar(@{$arrayOfArrays}) == 0 ){

            # has the prep(s) been cancelled?
            $arrayOfArrays =
                $dbh->fetch_all(qq[
                                   select dp.PREP_NUMBER
                                   from   DNAPREP dp, DNAPREP_STATUS dps
                                   where  dp.CLONENAME  = '$cloneName'
                                   and    dp.ID_PREP    = dps.ID_PREP
                                   and    dps.ISCURRENT = 1
                                   and    dps.STATUS    = 9
                                   order by PREP_NUMBER ]);

            if( scalar(@{$arrayOfArrays}) > 0 ){
                LemurUtils->showError($self->{mw},
                                      "All the preps for '$cloneName' have ".
                                      "been cancelled or the clone has not ".
                                      "yet been assigned to a subcloner");
            }
            else
            {
                # if you ever get this message, means either the clonename field
                # has not been filled in in the DNAPrep record or no DNA Prep
                # record.

                LemurUtils->showError($self->{mw},
                                      "Have you been assigned clone ".
                                      "'$cloneName'? If you think you have ".
                                      "email bug and let them know, giving ".
                                      "full details.");
            }

	} else {	   
	    foreach my $array ( @$arrayOfArrays ) {
		$self->{DNAPrepNumWidget}->insert('end', $array->[0]);
	    }

	    if( scalar(@$arrayOfArrays) == 1 ) {
		$self->{DNAPrepNum} = $arrayOfArrays->[0]->[0];
	    }
	}
    };

    if($@) {
	warn "error == $@\n";
	LemurUtils->showError($self->{mw}, "$@");
    }

    LemurUtils->unSetWait([$self->{mw}]);
}


################################################################################
# bound to <Return> key press on Clone Entry widget.
################################################################################

sub searchForCloneName {

    my ($self) = @_;
    my $goodCloneName = 1;
    my $arrayOfArrays;
    my $searchValue = $self->{cloneName};

    my $entry_widget =
	$self->{searchWidget}->Subwidget("entry")->Subwidget("entry");
    LemurUtils->setWait([$self->{mw}, $entry_widget]);

    my $dbh;

    eval {
        $dbh = $self->connect_to_oracle();

	$arrayOfArrays = $dbh->fetch_all("
            select CLONENAME
            from   CLONE
            where  CLONENAME like '%$searchValue%'
            order by CLONENAME");

	$self->{searchWidget}->delete('0', 'end');

	foreach my $array ( @$arrayOfArrays ) {
	    $self->{searchWidget}->insert('end', (@$array)[0]);
	}

	# display the drop down window. 
        # Note: BtnDown is not a 'public' method.

	$self->{searchWidget}->BtnDown if ($self->{searchWidget}->{"popped"});
        $self->{searchWidget}->BtnDown;
    };

    LemurUtils->unSetWait([$self->{mw}, $entry_widget]);

    # Let user know  if anything bad happened while accessing the database.

    if($@) {
	LemurUtils->showError($self->{mw}, "$@");
    }
}

###############################################################################
# Callback on Frag Method Optionmenu. The fragmentation method used 
# determines the sizes of the fragments that are obtained.
#
# $self->{fragmethod} is the global textvariable for the frag method 
# Optionmenu.
#
###############################################################################

sub changeFragMethod {
    my ($self) = @_;
    my @list;

    @list = @{$fragSizeHash{$self->{fragMethod}}};
    my $fromToArray = $self->{variableBandsArray};

    foreach my $x (0..3) {
	$list[$x] =~ /^(\d+\.?\d*|\.\d+) - (\d+\.?\d*|\.\d+)$/;
	my $from = $1;
	my $to   = $2;

	# if list[$x] is empty, $1 & $2 can have the OLD values in them...

	if( $list[$x] eq '' ) {
	    $from = '';
	    $to   = '';
	}

#warn "changeFragMethod :: string = $list[$x], vars = $from - $to\n" if $debug;
#warn "changeFragMethod :: $1 - $2\n" if $debug;

	$fromToArray->[$x+1][0] = $from;
	$fromToArray->[$x+1][1] = $to;
    }

    # these are hard coded defaults - nasty.

    if( $self->{fragMethod}    eq 'Sonication' ) {
        $self->{variableBandUsed} = 2;
    }
    elsif( $self->{fragMethod} eq 'Needle-shear' ) {
        $self->{variableBandUsed} = 2;
    }
    else {
	$self->{variableBandUsed} = 0;
    }
}


################################################################################
# if isGoodDate returns 0, tells user date is bad.
################################################################################

sub isGoodDateEntered {

    my ($self) = @_;

    unless( $self->isGoodDate($self->{dateDone}) ) {
 
	if( ! ( $self->{dateDone} =~ m|(\d{1,2})/(\d{1,2})/(\d{4})$|) ) {
	    LemurUtils->showError($self->{mw},
				  "Date is not valid. ".
				  "Is it in dd/mm/yyyy format?");
	}else {
	    LemurUtils->showError($self->{mw}, "Date is not valid.");
	}

	return 0;
    }

    return 1;
}


################################################################################
# createCloneFrame
#
# Arguments;
#           cloneF  - Frame to put gadgets in
################################################################################

# not called

sub createCloneFrame {

    my ($self, $cloneF) = @_;

    my $cf = $cloneF->Frame(-relief => 'groove', -borderwidth => 3);
    print "wibble\n";
    my $row = 1;

    $cf->Label(-width  => 14,
	       -text   => 'Last Clone', 
	       -anchor => 'w'
	       )->grid(-row    => $row,
		       -column => 1,);

    $cf->Label(-width  => 14,
	       -anchor => 'w',
               -textvariable => \$self->{last_clone_entered},
	       )->grid(-row    => $row,
		       -column => 2,);
    ++$row;

    $cf->Label(-width  => 14,
	       -text   => 'Clone Name', 
	       -anchor => 'w'
	       )->grid(-row    => $row,
		       -column => 1,);

    $self->{searchWidget} =
	$cf->BrowseEntry(-width     => 18,
			 -relief    => 'sunken',
			 -variable  => \$self->{cloneName},
			 -browsecmd => sub {
			     $self->cloneNameEntered();
			 },
			 )->grid(-row    => $row, 
				 -column => 2, 
				 -sticky => 'nw');

    $self->{searchWidget}->bind('<KeyPress-Return>',
				sub { $self->searchForCloneName; });

    # grid centres the frame in the middle of the page, pack() does not...

    $cf->grid(-row    => 1,
	      -column => 1,
	      -pady   => 5,
	      -ipady  => 10);
}



################################################################################
# setup $self->{vectorsWithEnzymes} hash table.
# only gets the vectors with entries in the VECTORSITE_ENZYME table
#
# glues vector name to enzyme, which becomes then lookups return the 
# ID_VECTORSITE e.g.
#
#    $self->{vectorsWithEnzymes}->{"puc18 (HindIII)"  => 1,
#                                  "mp13mp18 (BamHI)" => 2}
#
################################################################################

sub getVectorsWithEnzymes {

    my ($self, $dbh) = @_;
    my ($arrayOfArrays, $arrayRef);
    my %vectors;
    my ($arrayOfArraysLigNum, $fetchRef, $arrayRefLigNum);

    $arrayOfArrays = $dbh->fetch_all("
        select v.VECTORNAME, ve.ENZYMENAME, v.ID_VECTORSITE
        from   VECTORSITE v, VECTORSITE_ENZYME ve
        where  v.ID_VECTORSITE = ve.ID_VECTORSITE");

    my $ligh = $self->{cache}->{sql}->{lig_batch_for_id_vectorsite};

    my $ligh = $dbh->prepare(q[ select ID_LIGBATCH
                                from   LIGATION_BATCH
                                where  SEQ_VECTOR =  ?
				order by ID_LIGBATCH]);
 
    foreach $arrayRef (@$arrayOfArrays) {

	$ligh->execute($arrayRef->[2]);
	$fetchRef = $ligh->fetch();

	my @ligNumArray;

	while( $fetchRef ) {
	    push @ligNumArray, $fetchRef->[0];
	    $fetchRef = $ligh->fetch();
	}

	my $name = "$arrayRef->[0] ($arrayRef->[1])";

	$vectors{$name}->{ID_VECTORSITE} = $arrayRef->[2];
	$vectors{$name}->{ligations}     = \@ligNumArray;
    }

    $self->{vectorsWithEnzymes} = \%vectors;
}


################################################################################
# is Good Date
#
# 1. check format is correct dd/mm/yyyy
# 2. check year > 1999
# 3. get num days for month from hash. If not in hash, invalid.
#    Feb is a specail case, check for leaps years etc.
#
# RETURNS:  1 if date is good, 0 otherwise.
################################################################################

sub isGoodDate {

    my ($self, $date) = @_;
    my $dateOK        = 1;

    if( $date =~ m|(\d{1,2})/(\d{1,2})/(\d{4})$| ) {

	my $day   = $1;
	my $month = $2;
	my $year  = $3;

	# check year

	if($year < 1999) { # year this program was first written
	    $dateOK = 0;
	}else {

	    # check month/days in month

	    my @month30  = [9, 4, 6, 11];
	    my @month31  = [1, 3, 5, 7, 8, 10, 12];
	    my @monthFeb = [2];

	    my %monthHash = (1  => 31,  #
			     3  => 31,  # feb specail case.
			     4  => 30,
			     5  => 31,
			     6  => 30,
			     7  => 31,
			     8  => 31,
			     9  => 30,
			     10 => 31,
			     11 => 30,
			     12 => 31);

	    if( $month == 2 ) {
		# feb specail case, leaps years etc.

		my $feb = 28;

		if( ($year % 400) == 0) {
		    # year 2000 or this program has lasted bloody well.
		    $feb = 29;
		}elsif( ($year % 4) == 0) {
		    $feb = 29;
		}else{
		    $feb = 28;
		}

		if( $day > $feb ) {
		    $dateOK = 0;
		}

	    }else {
		my $maxDays = $monthHash{$month};
		
		if($maxDays == undef() || $day > $maxDays) {
		    $dateOK = 0;
		}
	    }
	}
    } else {
	$dateOK = 0;
    }

    return $dateOK;
}


################################################################################
# setup $self->{vectors}->{myVectorName}->[array of batch numbers]
#
# Loop through doing SQL for each vector.
# Store batch numbers for each one in an array. Use array as the value with
# the key as the vector name
################################################################################

# IS THIS SUB EVER CALLED ??????????????????????

sub getLigBatches {

    my ($self) = @_;
    my ($arrayOfArrays, $arrayRef);


    my ($dbh);

    eval {
        $dbh = $self->connect_to_oracle();

	# loop for each vector name

	foreach my $vectorName (keys %{$self->{vectors}}) {

	    $arrayOfArrays = $dbh->fetch_all("
                select ID_LIGBATCH
                from   LIGATION_BATCH lb, VECTORSITE vs
                where  lb.SEQ_VECTOR        = vs.ID_VECTORSITE
                and    lower(vs.VECTORNAME) = lower('$vectorName')");

	    # loop for each row retrieved for $vectorName, add to array

	    my $x = 0;
	    my (@ligBatches);

	    foreach $arrayRef (@$arrayOfArrays) {
		$ligBatches[$x] = $arrayRef->[0];
		++$x;
	    }

	    $self->{vectors}->{$vectorName} = \@ligBatches;
	}
    };
    
    if($@) {
	$self->expire("$@");
    }
}


################################################################################
# If adding a new set or sets of ligations, just updates the batchNumberToSee
# for the correct vector.
#
# If adding to an old batch (batchIDWidget exists):
# Get the array reference holding the possible batch numbers for this ligation.
# Give this to the browse entry widget as the list of choices. The array can
# be empty.
################################################################################

sub getLigBatchNow {

    my ($self, $selection) = @_;
    my $arrayRef;

    unless($self->{batchIDWidget} ) {

	$self->{batchNumberToSee} = 
	    $self->{id_ligbatch}->{$self->{pickedVector}};
    }

    return unless($self->{batchIDWidget}); # Entering new Batch ID, no widget.

    $arrayRef = $self->{vectorsWithEnzymes}->{$selection}->{ligations};

    $self->{batchIDWidget}->configure(-choices => $arrayRef);
    $self->{ligBatch} = '';
}

# user enters batch number (will only ever get called if adding ligations(s)
# to an old batch). Displays all available batch nums matching the one typed
# in.
#
# NOTE: the number of batches in the system will always be on the increase
#       so stroing all the ligbatches against Vector (enzyme) will use lots of 
#       memory - THIS WILL HAVE TO CHANGE
#
sub searchLigBatchNow {
    my ($self, $batchNum) = @_;

    unless( defined($self->{pickedVector}) && $self->{pickedVector} ne '' ){
        LemurUtils->showError($self->{mw}, "Please select the vector first");
        return;
    }

    return if $batchNum eq ''; 

    my @array;
    my $arrayRef =
	$self->{vectorsWithEnzymes}->{$self->{pickedVector}}->{ligations};

    foreach (@{$arrayRef}) {
	push @array, $_ if $_ =~ /$batchNum/;
    }

    $self->{batchIDWidget}->configure(-choices => \@array);

    # display the drop down window. 
    # Note: BtnDown is not a 'public' method.

    $self->{batchIDWidget}->BtnDown if ($self->{batchIDWidget}->{"popped"});
    $self->{batchIDWidget}->BtnDown;
}


################################################################################
# just gets the next number in the sequence for the LIGATION_BATCH table.
################################################################################

sub getNewLigationBatchNumber {

    my ($self) = @_;
    my ($id_ligation_batch);

    my ($dbh);

    eval {
        $dbh = $self->connect_to_oracle();

	$id_ligation_batch = $dbh->fetch_scalar("
             select seq_ligbatch.nextval
             from   dual");
    };
    
    if($@) {
	$dbh->rollback if $dbh;
	$self->expire("$@");
    }

    # display number to user
    my $selected = $self->{chooseVector}->info('selection');

    LemurUtils->showInfo($self->{mw},
			 "The new Batch number for $selected is\n ".
			 "$id_ligation_batch");

    # add number to BrowseEntry widget.
    $self->{ligBatchWidget}->insert('end', "$id_ligation_batch");
    $self->{ligBatch} = $id_ligation_batch;
}


################################################################################
# if the value isn't supplied it defaults to zero.
################################################################################

sub setupProgressMeter {
    my ($self, $from, $to) = @_;

 return;

    $self->{wd} = 
	$self->{mw}->WaitBox(-title => 'Please wait...',
			     -cancelroutine => sub {
				 ################################
				 # Need to stop things gracefully
				 ################################
				 $self->{wd}->unShow;
			     }
			     );
	
    $self->{wd}->wm('minsize', 400, 80);
    $self->{wd}->wm('maxsize', 400, 80);
    my $f = $self->{wd}->Frame(-height => 80, -width => 400);
    $f->pack();
    $self->{wd}->withdraw;
    $self->{mw}->idletasks();
    $self->{wd}->packPropagate(0);
    $f->packForget();
    $self->{wd}->configure(-txt1 => "Checking data...");

    $self->{u} = $self->{wd}->Frame()->pack(side => 'top', fill => 'x');
    #$u->Label(-textvariable => \$utxt)->pack(-expand => 1, -fill => 'both');

    $self->{base} = $self->{u}->Frame(-background  =>'gray',
				      -relief      => 'sunken',
				      -borderwidth => 2,
				      -height      => 20
				      )->pack(-side   => 'left',
					      -anchor => 'w',
					      -expand => 1,
					      -fill   => 'both');

    $self->{bar} = $self->{base}->Frame(-borderwidth => 2,
					-relief      => 'raised',
					-height      => 20,
					-width       => 0,
					-background  => 'lemonchiffon2'
					)->pack(-fill => 'y',
						-side => 'left');

    $self->{wd}->configure(-canceltext => 'Cancel plot'); # default is 'Cancel'

    $self->{scale_value} = 0;

    $self->{wd}->Show();
}


# if the value isn't supplied it defaults to ten

sub incProgressMeter {
    my ($self, $value) = @_;

return;

    unless( $value ) {
	$self->{scale_value} += 7;
    }
    else {
	$self->{scale_value} += $value;
    }

    $self->{bar}->configure(-width => $self->{scale_value} );

    my $old_width = $self->{base}->Width;

    # 100 could be the number of times this would be called....
    # arbitary number now

warn "\n*** incProgressMeter $self->{scale_value} / 100 * $old_width ***\n\n" if $debug;

    my $new_width = int($self->{scale_value} / 100 * $old_width);
    $self->{bar}->configure(-width => $new_width );

    $self->{mw}->update('idletasks');
}


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

return;

    $self->{wd}->unShow();
}


################################################################################
# The next button does the same as the OK button but does not hide the 
# window. It clears the contents, ready for the next clone.
################################################################################

#sub nextPressed {

#    my ($self)    = @_;
#    my $cloneName = $self->{cloneName};

#    if( $self->okPressed() ) {

#	warn "okPressed() returned TRUE\n" if $debug;

	# If got to here, data entered by user was good. 
        # Records in DB have been created.

#	$self->{cloneName}   = '';
#	$self->{DNAPrepNum}  = '';

#	$self->{searchWidget}->Subwidget("entry")->Subwidget("entry")->focus();
#    }
#}

sub addNextClone {
    my ($self)    = @_;
    my $lig_num;
    

    if( $lig_num = $self->lig_already_exists_for_clone($self->{cloneName}) ){
        my $answer =
            LemurUtils->yesNo($self->{mw},
                              "Ligation $lig_num has already been created for ".
                              "clone $self->{cloneName}. Do you want another?");
        return if $answer eq 'No';
    }

    if( $self->createRecords() ) {
	warn "createRecords() returned TRUE\n" if $debug;

	# If got to here, data entered by user was good. Records created.

        $self->set_last_clone_used( $self->{cloneName} );

	$self->{cloneName}   = '';
	$self->{DNAPrepNum}  = '';
	$self->{searchWidget}->focus();
    }
}

sub lig_already_exists_for_clone {
    my ($self, $clone_name) = @_;
    my $dbh;
    my $lig_num;

    return undef if $clone_name eq '';


    eval {
        $dbh = $self->connect_to_oracle();

        my $sth = $dbh->prepare(q[SELECT id_ligation
                                  FROM   ligation
                                  WHERE  clonename = ? ]);
        $sth->execute($clone_name);
        ($lig_num) = $sth->fetchrow_array();
    };

    die "$@" if $@;

    return $lig_num
}

sub finished {
    my ($self) = @_;
    my ($dbh);

    if(   !defined($self->{ligationCache}) 
       || (scalar(@{$self->{ligationCache}}) == 0) ){ 
	LemurUtils->showError($self->{mw},
			      "You did not enter any ligations!!!");
	return 0;
    }

    eval {
        $dbh = $self->connect_to_oracle();

        LemurUtils->setWait([$self->{mw}]);

        $self->set_feed_back("Creating Ligations in Oracle...");
	$self->createLigations($dbh);

        $self->set_feed_back("Updating DNA Prep status...");
	$self->updateDNAPrepStatus($dbh);

        $dbh->commit();
        $self->set_feed_back("Data entered into Oracle");
        print "done Oracle commit\n" if $debug;

        $self->printLigSheet($dbh);

        $self->set_last_clone_used('');
    };

    if( $@ ) {
        my $error = $@;
        LemurUtils->unSetWait([$self->{mw}]);

        # see if label printer is off line
        if( $error =~ /Label Printer/ ){
            LemurUtils->showError($self->{mw},
                                  "The label printer is currently off line. ".
                                  "Please use the program 'reprint' when the ".
                                  "printer is working again");
            $self->set_feed_back("");
            return 1;
        }

	LemurUtils->showError($self->{mw},
                              "$error. ".
                              "Please see bug to find out if the ligation ".
                              "numbers can be used.");
	$dbh->rollback();
        print $error, "\n";
	warn "done Oracle rollback" if $debug;
	return 0;
    }

    $self->set_feed_back("");
    return 1;
}

################################################################################
# Need to validate input from user. If ok, save away to Oracle.
#
# Returns;
#         0 - if bad data
#         1 - if good data.
################################################################################

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

    my $cloneName = $self->{cloneName};
    my $dataOK    = 1;        # boolean. If ever set to 0, some data is invalid.
    my $mustEnter = "You must enter ";

    # if they haven't even choosen a Vector, show error and return

    unless( $self->{pickedVector} ) {
	LemurUtils->showError($self->{mw}, "You must choose a Vector.");
	return 0;
    }

    # validate the Clone Name
    my ($dbh);

    eval {
        $dbh = $self->connect_to_oracle();

	if( $cloneName eq '' ) {
	    $mustEnter .= "a clone name, ";
	    $dataOK     = 0;
	}
	elsif( ! $self->checkCloneName($cloneName, $dbh) ){
	    LemurUtils->showError($self->{mw},
				  "The Clone '$cloneName' does not exist ".
				  "in the database.");
	    $dataOK = 0;
	}
    };
    
    if($@) {
	$self->expire("$@");
    }

    # check a DNA Prep Num was selected
    if($self->{DNAPrepNum} eq '') {
	$mustEnter .= "a DNA Prep number, ";
	$dataOK     = 0;
    }

    # check operator name was selected.
    if( ! defined($self->{operator}) || $self->{operator} eq '' ){
        $mustEnter .= "you - the operator, ";
	$dataOK     = 0;
    }


    # report if Date Done ok or not.
    unless( $self->isGoodDate($self->{dateDone}) ) {
	$mustEnter .= "a valid Date, ";
	$dataOK     = 0;
    }

    # check user selected some Bands Recovered
    my (@bands, @bands_entered);

    foreach my $x ( 1..4 ){
        my $from = $self->{variableBandsArray}->[$x][0];
        my $to   = $self->{variableBandsArray}->[$x][1];

	if( $from && $to ){

            # IS FRAG A VALID NUMBER?
            if( LemurUtils->isValidNumber($from) &&
                LemurUtils->isValidNumber($to)     ){

                # MUST NOT BE 2 - 1.4. This blows up Gap...
                if( $from >= $to ){
                    $mustEnter .= "valid band sizes ('$from - $to'), ";
                    $dataOK     = 0;  
                }
                else {
                    push @bands, "$self->{variableBandsArray}->[$x][0] - ".
                        "$self->{variableBandsArray}->[$x][1]";
                    push @bands_entered, $x;
                }
            }
            else {
                $mustEnter .= "valid band sizes ('$from - $to'), ";
                $dataOK     = 0;  
            }
	}
#        else {
#            print "Empty: $self->{variableBandsArray}->[$x][0] - ".
#		"$self->{variableBandsArray}->[$x][1]:\n\n";
#        }
    }


    if( scalar(@bands) == 0 ) {

	unless( $self->{fragMethod} eq 'No Fragmentation Done' ) {
	    $mustEnter .= "at least one band size, ";
	    $dataOK     = 0;
	}
    }
    else {
        unless( $self->{variableBandUsed} ){
            $mustEnter .= "select the fragment you used, ";
	    $dataOK     = 0; 
        }
        else {
            unless( grep /$self->{variableBandUsed}/, @bands_entered ){
                $mustEnter .= "a valid fragment you used, ";
                $dataOK     = 0;
            }
        }
    }

    if($self->{volumeUsed} eq '' ) {
	$mustEnter .= "the Volume Used, ";
	$dataOK     = 0;
    }
    else {
        unless( LemurUtils->isValidNumber($self->{volumeUsed}) ){
	$mustEnter .= "a valid number for the Volume Used, ";
	$dataOK     = 0;            
        }
    }

    # CHECKING DONE. If it was valid data, throw it into some tables.

    if( $dataOK ) {
	$self->incProgressMeter();
	$dataOK = $self->createRecordInDB;

	if( $dataOK ) {
	    $self->{batchNumberToSee} = 
		$self->{id_ligbatch}->{$self->{pickedVector}};
	}
    }
    else {
	unless( $mustEnter =~ /^You must enter $/ ) {
	    $mustEnter =~ s/,\s$/./;           # strip off ', ' at end
	    LemurUtils->showError($self->{mw}, $mustEnter);
	}
    }

    return $dataOK;
}


################################################################################
# Returns true if $cloneName exists in a CLONE record
################################################################################

sub checkCloneName {
    my ($self, $clone_name, $dbh) = @_;

    if( $clone_name eq '' ) {
	return( 0 );
    }

    my $sth = $dbh->prepare(q[select count(*) 
                              from   CLONE 
                              where  CLONENAME = ? ]);
    $sth->execute($clone_name);
    my ($count) = $sth->fetchrow_array();

    return ($count);
}


################################################################################
# get data inputted into widgets and insert into various tables
#
# records created are: Fragmentation, 
#                      FragmentationBand (x 4 usually)
#                 x     Ligations         (x 2 usually - M13mp18 & pUC18)
#
# NOTE: the ligation details are "cached"  but not created till the finished
#       button is pressed. This is so a block of x ligation numbers in sequence
#       can be obtained instead of 1, 3, 4, 5, 8.
#
# Returns;
#         1 if created the records OK.
#         0 if error occured. (will display MessageBox to show user the error).
################################################################################

sub createRecordInDB {
    my ($self) = @_;
    my $dataOK = 1;
    my ($id_frag, $id_fragBand);

    my $dbh;

    eval {
        $dbh = $self->connect_to_oracle();

	warn "\n********* started creating records *********\n\n" if $debug;

	$id_frag = $self->createFragmention($dbh);
	$self->incProgressMeter();
	warn "created Fragment, id_frag = $id_frag\n"             if $debug;

	$id_fragBand = $self->createFragmentBand($dbh, $id_frag);
	$self->incProgressMeter();
	warn "created FrgamentBand, id_fragBand = $id_fragBand\n" if $debug;

#	$self->createLigations($dbh, $id_fragBand);
	$self->cacheLigations($id_fragBand);
	$self->incProgressMeter();
	warn "created Ligation(s)\n"                              if $debug;


    };
    
    if($@) {
	$dbh->rollback if $dbh;

	if( $@ =~  /Bad Data From User/  or $@ eq "\n") {
	    # message already displayed.
	    warn "done rollback\n" if $debug;
	    $dataOK = 0;
	} else {
	    LemurUtils->showError($self->{mw}, "$@");
            
	    $dataOK = 0;
	}
    }

    return $dataOK;
}

sub set_last_clone_used {
    my ($self, $clone_name) = @_;

    $self->{last_clone_entered} = $clone_name;
}

################################################################################
# using the data the user has input, gets the details needed to fill in a 
# Fragement record and inserts it. 
#
# NOTE: although this is called 'createFragmentation' it may not actaully create
#       anything. The user may have inputted details of this part of the 
#       experiment for a previous vector. If this is the case, it just returns
#       the ID of the correct FRAGMENTATION.
#
# Arguments;
#           dbh     - database handle
# Returns;
#           ID_FRAG - ID of fragmentation record created.
################################################################################

sub createFragmention {
    my ($self, $dbh, $args) = @_;
    my $sql_cache  = $self->{cache}->{sql};
    my $cloneName  = $self->{cloneName};
    my $DNAPrepNum = $self->{DNAPrepNum}; # change on gadget varable to id_prep
    my $operator   = $self->{operator};

    $sql_cache->{get_id_prep}->execute($cloneName, $DNAPrepNum);
    my ($id_prep) = $sql_cache->{get_id_prep}->fetchrow_array();
    $sql_cache->{get_id_prep}->finish();

    if( ! $id_prep  ) {
	LemurUtils->showError($self->{mw},
			      "There is no DNA Prep Number $DNAPrepNum ".
			      "for clone $cloneName");
	die "Bad Data From User";
    }

    print "DNAPrep Num == $DNAPrepNum\n" if $debug;
    print "        id  == $id_prep\n\n"  if $debug;

    my $id_recoveryMethod = $recoveryMethodHash{$self->{recoveryMethod}};
    my $id_fragMethod     = $fragMethodHash{$self->{fragMethod}};

    # check FRAGMENTATION record has not already been entered. See NOTE above.
    $sql_cache->{get_id_frag}->execute($id_prep,
                                       $id_recoveryMethod,
                                       $id_fragMethod,
                                    $self->{operatorHash}->{$self->{operator}});
    my ($id_frag, $vol_used) =  $sql_cache->{get_id_frag}->fetchrow_array();
    $sql_cache->{get_id_frag}->finish();

    if( $id_frag ) {
        if( $debug ){
            print "\ncreateFragmention:: id_prep == $id_prep\n";
            print "                    Fragmentation record already created\n";
        }

        # update the Volume used for this type of fragmentation for given prep
        $vol_used += $self->{volumeUsed};

        $sql_cache->{update_vol_used}->execute($vol_used, $id_frag);

#        $dbh->do(qq[update FRAGMENTATION
#                    set    VOL_USED = $vol_used
 #                   where  ID_FRAG  = $id_frag ]);

	return $id_frag; # DNAPREP_FRAG & FRAGMENTATION already enetered
    }

    $id_frag = 
	$dbh->fetch_scalar("select seq_fragmentation.nextval from dual");

    # FRAGMENTATION
    $sql_cache->{insert_fragmentation}->execute($id_frag,
                                                $id_recoveryMethod,
                                                $id_fragMethod,
                                     $self->{operatorHash}->{$self->{operator}},
                                                $self->{volumeUsed} );

#    $dbh->do("
#       insert into FRAGMENTATION
#              (ID_FRAG,
#               RECOVERY_METHOD,
#               FRAG_METHOD,
#               OPERATOR,
#               VOL_USED)
#       values ($id_frag,
#               $id_recoveryMethod,
#               $id_fragMethod,
#               '$self->{operatorHash}->{$self->{operator}}',
#               $self->{volumeUsed})");

    # DNAPREP_FRAG

    $sql_cache->{insert_dnaprep_frag}->execute($id_prep, $id_frag);

#    $dbh->do("
#           insert into DNAPREP_FRAG
#                  (ID_PREP,
#                   ID_FRAG)
#           values ($id_prep,
#                   $id_frag)");

    return $id_frag;
}


################################################################################
# Creates a fragmentation band record for each band recovered.
#
# Arguments;
#           dbh     - database handle

#           id_frag - id of Fragment record created before this sub called
#
# Returns;
#           ID_FRAGBAND - id of the fragmentation band used for ligation
################################################################################

sub createFragmentBand {
    my ($self, $dbh, $id_frag, $args) = @_;

    my ($fragIndexUsed) = 0;
    my ($id_fragband);
    my ($return_id_fragBand);

    my $id_fragMethod =	$dbh->fetch_scalar(
       "select ID_DICT 
        from   FragMethodDict 
        where  Description = '$self->{fragMethod}'");

    my @bands;

    $fragIndexUsed = $self->{variableBandUsed};
    my $refToArray = $self->{variableBandsArray};
    my ($from, $to);

    foreach my $x ( 1..4 ) {

	if( $refToArray->[$x][0] && $refToArray->[$x][1]) {

	    $from = $refToArray->[$x][0];
	    $to   = $refToArray->[$x][1];

warn "createFragmentBand:: x = $x, band used =  $fragIndexUsed\n" if $debug;


	    $id_fragband = $dbh->fetch_scalar("
                select ID_FRAGBAND
                from   FRAGMENTATION_BAND
                where  ID_FRAG      = $id_frag
                and    SIZE_FROM_KB = $from
                and    SIZE_TO_KB   = $to");


	    if( $id_fragband ) {
		warn "createFragmentBand::id_fragband of $id_fragband ".
		     "already used\n" if $debug;

		if( $x == $fragIndexUsed ) {
		    $return_id_fragBand = $id_fragband;
		}

		next;
	    }

	    $id_fragband = $dbh->fetch_scalar("
                select seq_fragband.nextval from dual");

	    warn "
                insert into FRAGMENTATION_BAND
                       (ID_FRAGBAND,
                        ID_FRAG,
                        SIZE_FROM_KB,
                        SIZE_TO_KB,
                        FRAGMENT_BOX)
                values ($id_fragband,
                        $id_frag,
                        $from,
                        $to,
                        $self->{fragBox}) \n" if $debug;

	    $dbh->do("
                insert into FRAGMENTATION_BAND
                       (ID_FRAGBAND,
                        ID_FRAG,
                        SIZE_FROM_KB,
                        SIZE_TO_KB,
                        FRAGMENT_BOX)
                values ($id_fragband,
                        $id_frag,
                        $from,
                        $to,
                        '$self->{fragBox}')");

	    if( $x == $fragIndexUsed ) {
		$return_id_fragBand = $id_fragband;
	    }
	}
    }

    return $return_id_fragBand;
}

# the FRAGMENTATION_BAND record has already been created, regardless of whether
# the ligation(s) will be created!

sub cacheLigations {
    my ($self, $id_fragBand) = @_;
    my $array = [
		 $self->{pickedVector},
		 $self->{cloneName},
		 $id_fragBand,
		 $self->{dateDone},
		 $self->{DNAPrepNum},
                 -1 # volume used not entered yet!
		 ];


	my (
	    $remark);

    my $used = $self->{variableBandUsed}; # range 1..4 - frag sizes

    # {ligNum} added to each hash when ligation recorded created
    my $hash  = {
	         pickedVector => $self->{pickedVector},
		 cloneName    => $self->{cloneName},
		 id_fragBand  => $id_fragBand,
		 dateDone     => $self->{dateDone},
		 DNAPrepNum   => $self->{DNAPrepNum},
		 volumeUsed   => $self->{volumeUsed},
		 dateDone     => $self->{dateDone},
		 from         => $self->{variableBandsArray}->[$used][0],
                 to           => $self->{variableBandsArray}->[$used][1],
		 blue         => -1,
                 clear        => -1,
		 fragBox      => $self->{fragBox},
		 comment      => ''
		 };

warn "\ncache added \n", join("\n     ",@{$array}), "\n" if $debug;

    push @{$self->{ligationCache}},   $hash;
}


################################################################################
#
# creates new batch_id if one has not been created before for the pickedVector
# creates LIGATION record
# creates LIGATION_STATUS record
#
#                Positive == Clear, Negative == blue.
#
#
################################################################################

sub createLigations {
    my ($self, $dbh, $id_fragBand) = @_;
    my ($id_ligation);
    my ($vector_site);
    my $user    = $self->{realUserName};
    my $checked = 0;

    warn "\ncreateLigations::user == $user\n" if $debug;

    # this is to make sure no one else can get lig nums at the same time
    # same code in LemurEnterBatchOfJobs.pm
    eval {
	$dbh->fetch_all("select ID_LIGBATCH from LIGATION_BATCH for update");
    };

    foreach my $ligHash ( @{$self->{ligationCache}} ){
	my $pickedVector = $ligHash->{pickedVector};
	my $cloneName    = $ligHash->{cloneName};
	my $id_fragBand  = $ligHash->{id_fragBand};
	my $volume_used  = $ligHash->{volumeUsed};
	my $dateDone     = $ligHash->{dateDone};

	# create LIGATION_BATCH record. If no batch number exists for this 
	# vector then get one and store it for next ligation. First it
	# checks if the value stored internally is valid - what is stored 
	# and what is in the DB can be two different things if an error
	# occured before when writting to the DB!!

	if( !$checked && $self->{id_ligbatch}->{$pickedVector} ){
	    my $id = $dbh->fetch_scalar("
                select ID_LIGBATCH
                from   LIGATION_BATCH
                where  ID_LIGBATCH = $self->{id_ligbatch}->{$pickedVector}");

	    if( $id eq "" ){
		# holding dud value, delete it ready for code below
		delete $self->{id_ligbatch}->{$pickedVector};
	    }
            else {
                $checked = 1; # test once only!
            }
	}


	unless( $self->{id_ligbatch}->{$pickedVector} ) {

	    my $vecEnz   = $pickedVector;
	    $vector_site = 
		$self->{vectorsWithEnzymes}->{$vecEnz}->{ID_VECTORSITE};

	    $self->{id_ligbatch}->{$pickedVector} =
		$dbh->fetch_scalar("select seq_ligbatch.nextval from dual");

		warn "   creating new batch.\n"                if $debug;
		warn "   vector_site = $vector_site\n"         if $debug;
		warn "   id_ligbatch = ",
		    $self->{id_ligbatch}->{$pickedVector},"\n" if $debug;

	    $dbh->do("
                insert into LIGATION_BATCH
                       (ID_LIGBATCH, SEQ_VECTOR)
                values ($self->{id_ligbatch}->{$pickedVector},
                        $vector_site)");
	}
	else {
	    warn "   batch already created.\n"             if $debug;
	    warn "   vector_site = $vector_site\n"         if $debug;
	    warn "   id_ligbatch = ",
	        $self->{id_ligbatch}->{$pickedVector},"\n" if $debug;
	}

	# get numOfLig numbers for ligations. Lock LIGATION_BATCH so if 2 
	# instances of this application try to get a sequencial list of number
	# one will have to wait;

	my $ligNum =
	    $dbh->fetch_scalar(" select seq_LIGATION.nextval from dual ");

#        Mail::sendMail( -to      => 'pjm',
#                        -subject => "id_ligation number got $ligNum", 
#                        -message => "id_ligation = $ligNum (user = $user)");

        $self->set_feed_back("New Ligation Number is $ligNum");

	if( $debug ) {
	    warn "
                insert into LIGATION
                        (ID_LIGATION,
                         ID_FRAGBAND,
                         ID_LIGBATCH,
                         VOLUME,
                         POSITIVE,
                         NEGATIVE,
                         CLONENAME)
                 values ($ligNum,
                         $id_fragBand,
                         $self->{id_ligbatch}->{$pickedVector},
                         -1,
                         -1,
                         -1,
                         '$cloneName') \n"; 
	}

        $self->set_feed_back("About to insert new ligation $ligNum");

	eval {
	    $dbh->do("
                insert into LIGATION
                        (ID_LIGATION,
                         ID_FRAGBAND,
                         ID_LIGBATCH,
                         VOLUME,
                         POSITIVE,
                         NEGATIVE,
                         CLONENAME)
                 values ($ligNum,
                         $id_fragBand,
                         $self->{id_ligbatch}->{$pickedVector},
                         -1,
                         -1,
                         -1,
                         '$cloneName')");

            $self->set_feed_back("About to insert status record for Lig");

            my $status = 1;
            $status    = 2 if $self->{pathogen_mode};

	    $dbh->do("
                insert into LIGATION_STATUS
                values ($ligNum,
                        $status,
                        to_date('$dateDone', 'dd/mm/yyyy'),
                        1,
                        $self->{session_id},
                        'EnterBatchOfLigs',
                        '$user')");
	};

	if($@) {
            my $error = $@;
            
            Mail::sendMail( -to      => 'pjm',
                            -subject => "ERROR inserting $ligNum", 
                            -message => "id_ligation = $ligNum (user = $user)\n$error\n");

	    if($error =~ /\.FK\_LIGATION_BATCH\) violated/ ) {
		LemurUtils->showError($self->{mw},
				      "Could not use batch number stored ".
				      "internally - was there an earlier ".
				      "problem? Please press Cancel/Done ".
				      "and re-enter the batch");
		die "\n";
	    }
	    elsif($error =~ /\.PK\_LIGATION\) violated/ ) {
		# this should never happen... left in anyway...
		LemurUtils->showError($self->{mw},
				      "Has this ligation number been used ".
				      "before ($ligNum)? Please check. ".
                                      "The details have not been added ".
				      "to Database ");
		die "\n";
	    }
	    else {
		die "$error";
	    }
	}

        $self->set_feed_back("Ligation $ligNum inserted");

	$ligHash->{ligNum} = $ligNum;
    }
}

################################################################################
# Set all old DNAPREP_STATUS records field IS_CURRENT to 0.
# Add DNAPREP_STATUS record to show 'Ligations created'
################################################################################

sub updateDNAPrepStatus {
    my ($self, $dbh) = @_;

    foreach ( @{$self->{ligationCache}} ){

	my $cloneName    = $_->{cloneName};
	my $dateDone     = $_->{dateDone};
	my $DNAPrepNum   = $_->{DNAPrepNum};

	my $id_prep = $dbh->fetch_scalar("
            select ID_PREP 
            from   DNAprep 
            where  Prep_Number = $DNAPrepNum
            and    CloneName   = '$cloneName'");

	warn "\nupdateDNAPrepStatus::id_prep = $id_prep\n" if $debug;

        # Check the DNAPREP has not got a status of cancelled

if( 0 ){
        my ($c_date, $operator) = $dbh->fetch_row(qq[select STATUSDATE, OPERATOR
                                                     from   DNAPREP_STATUS
                                                     where  ID_PREP   = $id_prep
                                                     and    STATUS    = 9
                                                     and    ISCURRENT = 1 ]);

        if( $c_date ne '' ){
            LemurUtils->showError($self->{mw},
				  "Sorry, the DNAPREP, hence your ligation, ".
				  "has been cancelled by $operator on the ".
				  "$c_date.");
	    die "\n";
        }
}
	# if a ligation has already been done for this prep, return. No point
	# having to records saying the same thing.

	my $count = $dbh->fetch_scalar("
            select count(*)
            from   DNAPREP_STATUS
            where  ID_PREP = $id_prep
            and    STATUS  = 20");

	if( $count > 0 ) {
	    if( $debug ) {
		warn "WARNING: id_prep '$id_prep' has already been ligated\n";
		warn "         Not adding new status record.\n";
	    }

	    next;
	}

	# set/test lock on DNAPREP_STATUS records for this DNA Prep 
	# before updating them all to ISCURRENT = 0

	warn "updateDNAPrepStatus:: about to SET DNAPREP_STATUS \n" if $debug;

	my $error;

        $self->set_feed_back("Locking DNA Prep $id_prep...");

	eval {
	    $dbh->fetch_all("
                select ID_PREP from DNAPREP_STATUS
                where  ID_PREP   = $id_prep
                for update nowait");
	};

	if ($@ =~ /ORA-00054: resource busy and acquire with NOWAIT specified/){
	    LemurUtils->showError($self->{mw},
				  "Sorry, the status entries for prep ".
				  "$id_prep are locked by someone else. ".
				  "Try again later.");
	    die "\n";
	}
	else {
	    # wierd - get an error of 
	    #     "$h->rows count is incomplete before all rows fetched."
	    # i presume 'cos i said "nowait"
	    
	    # die "$error";
	}

	$dbh->do("
            update DNAPREP_STATUS
            set    ISCURRENT = 0
            where  ID_PREP   = $id_prep");

	if( $debug ) {
	    warn "updateDNAPrepStatus:: SET DNAPREP_STATUS iscurrent to 0\n";
	}

	# DNAPREP_STATUS.STATUS of 20 == 'Ligations created'

#    my $operator_id = $operatorHash{$self->{operator}};
	my $operator = $self->{realUserName};

	if( $debug ) {
	    warn "
                insert into DNAPREP_STATUS
                       (ID_PREP, STATUS, STATUSDATE,
                        ISCURRENT, SESSIONID, PROGRAM, OPERATOR)
                values ($id_prep , 20, to_date('$dateDone', 'dd/mm/yyyy'),
                        1, $self->{session_id},'Fragments.pm','$operator')\n\n";
	}

        $self->set_feed_back("Adding DNA Prep status...");

	eval {
	    $dbh->do("
                insert into DNAPREP_STATUS
                       (ID_PREP, STATUS, STATUSDATE,
                        ISCURRENT, SESSIONID, PROGRAM, OPERATOR)
                values ($id_prep , 20, to_date('$dateDone', 'dd/mm/yyyy'),
                        1, $self->{session_id}, 'Fragments.pm', '$operator')");
	};

	if($@) {
	    if( $@ =~ /unique constraint \(\w+\.PK\_DNAPREP\_STATUS\) violated/ ) {
		my $temp = $@; # $@ will get blown away after next statement...
		
		LemurUtils->showError($self->{mw},
				      "Could not create DNA Prep Status ".
				      "record. Please contact bug, giving ".
				      "details of what you entered.");
		die "Bad Data From User";
	    }
	    else {
		die "$@";
	    }
	}
    }
}

#
# returns 0 if did not work
#         1 if ok
#

sub writeToEquus {
    my ($self, $oracleDB) = @_;




    warn "EnterBatchOfLigs::writeToEquus\n" if $debug;

    # temp file is  program_host_pid  eg 'Lemur_galyep_30124'
    
    my $hostname  = Sys::Hostname::hostname();
    my $pid       = $$;
    my $prog      = $0;
    $prog         =~ s/.*\///;
    my $temp_file = $prog."_".$hostname."_".$pid."LemurBatchLigs";

    my $tFiles    = TempFiles->new(prefix => $temp_file,
				   dir    => $MAIN::EQUUS_TEMP_DIR);

    my $db        = EquusDatabaseInterface->new($tFiles,
						$self->{dbUser},
						$debug);

    # for eached cached ligation, get its details and addLigtion to Equus

# best thing to do is not have an array, have a hash pointing to everything 
# below + frag_band

    foreach my $ligHash ( @{$self->{ligationCache}} ){
	my $clone        = $ligHash->{cloneName};
	my $ligation     = $ligHash->{ligNum};
	my $dateDone     = $ligHash->{dateDone};
	my $vectorEnzyme = $ligHash->{pickedVector};
	my $id_fragBand  = $ligHash->{id_fragBand};
	my $volume       = -1;
	my $blue         = $ligHash->{blue};
	my $clear        = $ligHash->{clear};
	my $minSize      = $ligHash->{from};
        my $maxSize      = $ligHash->{to};
	my $fragmentBox  = $ligHash->{fragBox};
	my $remark       = $ligHash->{comment};

	$dateDone   =~ /(\d+)\/(\d+)\/(\d+)/;
	my $date =  "$3-$2-$1";

	# get 'vector' from 'vector (enzyme)'
	$vectorEnzyme =~ /^(.+) \(.+?\)$/;
	my $vector    =  $1;
	
warn "
    clone       $clone
    ligation    $ligation 
    date        $date 
    vector      $vector 
    minSize     $minSize 
    maxSize     $maxSize 
    volume      $volume  
    blue        $blue    
    clear       $clear   
    fragmentBox $fragmentBox 
    remark      $remark   
" if $debug;

	my @paths;
	
	if( $db->checkExists('Ligation', $ligation) ) {
	    LemurUtils->showError($self->{mw},
				  "Ligation $ligation already exists in ".
				  "Equus. Please contact bug");
	    $db->rollback;
	    warn "done Equus rollback" if $debug;
	    return 0;
	}

	@paths = $db->addLigation($clone,
				  $ligation,
				  $date,
				  $vector,
				  $minSize,
				  $maxSize,
				  $volume,
				  $blue,
				  $clear,
				  $fragmentBox,
				  $remark);

	if( scalar(@paths) == 0 ) {
	    $db->rollback;
	    warn "Equus rollback done (EnterBatchOfLigs)" if $debug;
	    return 0;
	}
    }

    $db->commit;
    warn "Equus commit complete (EnterBatchOfLigs)" if $debug;
    return 1;
}

#
#

sub printLigSheet {
    my ($self, $dbh) = @_;

    my $default_printer = 'd350bw';
#    my $printer         = ChoosePrinter->new($self->{mw}, $default_printer);
    my $printer         = ChoosePrinter->new($self->{mw});

    if( $printer eq '' ) {
        $printer = $default_printer; # one nearest Matt Jones.
	warn "Using default printer '$default_printer' \n";
    }
    else {
	warn "Using printer '$printer'\n";
    }

    my $row_h = $dbh->prepare("
       select dp.CLONENAME, fb.SIZE_FROM_KB, fb.SIZE_TO_KB,
              f.VOL_USED, vs.VECTORNAME, dp.PREP_NUMBER
       from   LIGATION l, FRAGMENTATION_BAND fb, FRAGMENTATION f,
              FRAGMETHODDICT fmd,
              DNAPREP_FRAG dpf, DNAPREP dp, LIGATION_BATCH lb, VECTORSITE vs
       where  l.ID_LIGATION = ?
       and    l.ID_LIGBATCH = lb.ID_LIGBATCH
       and    lb.SEQ_VECTOR = vs.ID_VECTORSITE
       and    l.ID_FRAGBAND = fb.ID_FRAGBAND
       and    fb.ID_FRAG    = f.ID_FRAG
       and    f.FRAG_METHOD = fmd.ID_DICT
       and    f.ID_FRAG     = dpf.ID_FRAG
       and    dpf.ID_PREP   = dp.ID_PREP");

    my $ligW   = 7;     # these are the widths of the columns
    my $cloneW = 13;
    my $fragW  = 12;
    my $kbW    = 4;
    my $volW   = 5;
    my $vecW   = 10;
    my $prepW  = 4;

    select(WORKSHEET);
    open(WORKSHEET,
	 "| genscript  -P$printer -b 'Work for: $self->{operator}\n".
	 "     Date printed: $self->{todaysDate}'");
#	 "| more");

    foreach my $vector ( keys %{$self->{id_ligbatch}} ){
	printf "%-20s : Batch $self->{id_ligbatch}->{$vector}\n", $vector;
	printf STDOUT "%-20s : Batch $self->{id_ligbatch}->{$vector}\n",
	    $vector;
    }

    printf "\n";
    printf STDOUT "\n";

    printf "%-${ligW}s | %-${cloneW}s | %-${kbW}s   %-${kbW}s | ".
	"%-${volW}s | %-${vecW}s | %-${prepW}s | Plated | Blue | Clear\n",
	'Lig No', 'Clone Name', 'Size', ' ', 'Vol', 'Vector', 'Prep';
    printf (("-" x $ligW)."-|".
	    ("-" x $cloneW)."--|".
	    ("-" x $kbW)."---".
	    ("-" x $kbW)."--|".
	    ("-" x $volW)."--|".
	    ("-" x $vecW)."--|".
	    ("-" x $prepW)."--|".
	     "--------|------|------\n");

    printf STDOUT "%-${ligW}s | %-${cloneW}s | %-${kbW}s   %-${kbW}s | ".
	"%-${volW}s | %-${vecW}s | %-${prepW}s\n",
	'Lig No', 'Clone Name', 'Size', ' ', 'Vol', 'Vector', 'Prep';
    printf STDOUT (("-" x $ligW)."-|".
		   ("-" x $cloneW)."--|".
		   ("-" x $kbW)."---".
		   ("-" x $kbW)."--|".
		   ("-" x $volW)."--|".
		   ("-" x $vecW)."--|".
		   ("-" x $prepW)."--|".
		   "\n");

    my $lig_label = Barcode->new();
    my $gel_label = Barcode->new();
    $lig_label->Type('LG');        # Ligation
#    $gel_label->Type('GS');        # Gel Slice

    # This is needed to force the Barcode module to look in Tracking not dev1
#    my $dbh = WrapDBI->connect('dodo', {RaiseError => 1});

    my $dbh;

    if( ! $debug ){
        $dbh = WrapDBI->connect('dodo', {RaiseError => 1});
    }
    else {
        $dbh = WrapDBI->connect('dev1', {RaiseError => 1});
    }

    $lig_label->Database(\$dbh);
#    $gel_label->Database(\$dbh);

    $lig_label->User($self->{realUserName});
#    $gel_label->User($self->{realUserName});


    foreach my $ligHash ( @{$self->{ligationCache}} ){

	my $ligNum = $ligHash->{ligNum};

	$row_h->execute($ligNum);
	my $row = $row_h->fetch();

	my $cloneName   = $row->[0];
	my $from_kb     = $row->[1];
	my $to_kb       = $row->[2];
	my $volumeUsed  = '';#$row->[3];
	my $vectorName  = $row->[4];
	my $prepNumUsed = $row->[5];

	printf "%-${ligW}s | %-${cloneW}s | %-${kbW}s - %-${kbW}s | ".
	     "%-${volW}s | %-${vecW}s | %-${prepW}s |        |      |      \n",
	     $ligNum, $cloneName, $from_kb ,$to_kb, $volumeUsed, 
	     $vectorName, $prepNumUsed;

	printf STDOUT "%-${ligW}s | %-${cloneW}s | %-${kbW}s - %-${kbW}s | ".
	     "%-${volW}s | %-${vecW}s | %-${prepW}s |\n",
	     $ligNum, $cloneName, $from_kb ,$to_kb, $volumeUsed, 
	     $vectorName, $prepNumUsed;

	# print ligation barcode
        $lig_label->Barcode( $ligNum);
        $lig_label->Name(    $ligNum);
        $lig_label->Project( $ligNum);
        $lig_label->Suffix(  $vectorName);
        $lig_label->Owner(   $cloneName);
        $lig_label->Date(    $self->{todaysDate} );

        $lig_label->Labellist();

        # print gel slice _labels_ - it don't need no barcode.
#        $gel_label->Barcode( $ligNum);
#        $gel_label->Name(    $from_kb."-".$to_kb);
#        $gel_label->Project( $ligNum);
#        $gel_label->Suffix(  $vectorName);
#        $gel_label->Owner(   $cloneName);
#        $gel_label->Date(    $self->{todaysMonthYear} );

#        $gel_label->Labellist();
    }

    $lig_label->Printlabel();
#    $gel_label->Printlabel();

    print STDOUT "\n";
    close(WORKSHEET);

    $dbh->disconnect;

    LemurUtils->showInfo($self->{mw},
			 "Please collect ligation sheet from printer $printer ".
                         "and labels from the barcode printer.");
}

################################################################################
# expire  :  send mail message and exit.
################################################################################

sub expire {
    my ($self, $message) = @_;

    warn "ERROR: $message";

    Mail::sendMail( -to      => 'bug',
                    -subject => "Lemur: Error entering ligation details.", 
                    -message => $message);
    die;
}


################################################################################
# EOF
################################################################################

1;

#
# $Log: LemurEnterBatchOfLigs.pm,v $
# Revision 1.47  2005/02/11  12:15:52  rmd
# Stopped the window size from being fixed.  Should prevent the buttons from
# disappearing off the bottom of the window on some machines.
#
# Revision 1.46  2003/05/28  13:12:03  mdf
# *** empty log message ***
#
# Revision 1.45  2003/05/28  11:59:30  mdf
# *** empty log message ***
#
# Revision 1.44  2000/12/13  16:17:17  pjm
# Frag size must go from - to. Added check that it frag size is not 2 - 1.4
# This blows up Gap...
#
# Revision 1.43  2000/11/14  14:03:55  pjm
# changed SQL to check person.iscurrent = 1 and to use aliases in getOperators().
#
# Revision 1.42  2000/10/05  16:49:44  pjm
# pjm no longer will be mail bombed by email for each lig num got from sequence
#
# Revision 1.41  2000/10/05  08:38:48  pjm
# Emails if any error happened at all when inserting records.
#
# Revision 1.40  2000/10/05  08:32:34  pjm
# emails pjm if any error happens when entering ligation or ligation_status
#
# Revision 1.39  2000/10/03  16:18:01  pjm
# 1. Would not have worked - greping for valid fragment_band logic was flawed
# 2. Added email to pjm to see whos getting ligation numbers.
#
# Revision 1.38  2000/10/03  09:07:08  pjm
# better validation of entering a band size.
#
# Revision 1.37  2000/09/26  14:19:21  pjm
# created sub prepare_sql() with 5 statements for now. Add more later.
# Benchmarking can be turned on by turning on debuging - CTRL-Middle Button over
# "Enter New Batch of Ligations" button.
#
# Revision 1.36  2000/09/20  16:11:50  pjm
# added &connect_to_oracle()
# added benchmarking to &setupHashTables()
# commented out call to &getVectors() - was big performance barrier :)
# upgraded &getFragMethods() to do 1 bit of SQL instead of lots.
#
# Revision 1.35  2000/09/08  13:54:25  pjm
# no longer writeToEquus - overnight cron adds/updates ligations into Equus
#
# Revision 1.34  2000/07/24  10:51:00  pjm
# VOLUME on ligation was being set with the vol used of the DNA prep when writing
# to Equus. Now set to -1.
#
# Revision 1.33  2000/07/04  13:49:28  pjm
# added (ID_LIGBATCH, SEQ_VECTOR) when inserting into LIGATION_BATCH
#
# Revision 1.32  2000/05/16  09:27:31  pjm
# forgot to add check to make sure Operator value was set.
#
# Revision 1.31  2000/04/26  11:33:10  pjm
# several minor changes: puts localtime into array, sets dateDone to todaysDate
# , corrected writting to writing.
#
# Revision 1.30  2000/04/05  14:57:22  pjm
# changed LemurEnterBatchOfLigs.pm to  EnterBatchOfLigs
#
# Revision 1.29  2000/04/05  12:23:42  pjm
# made program filed say 'LemurEnterBatchOfLigs.pm' rather tha 'EnterBatchOfLigs'
#
# Revision 1.28  2000/03/24  11:40:23  pjm
# made it so "super users" can enter a ligation for a prep that has not yet
# been assigned to a subcloner (prep status 15).
#
# Revision 1.27  2000/03/01  15:01:44  pjm
# made volume used on work sheet blank - that gets entered with the scores.
#
# Revision 1.26  2000/02/22  11:58:09  pjm
# Takes a pathogen_mode as argument in new(). If in pathogen mode it will
# set the LIGATION_STATUS to 2, not 1.
#
# Revision 1.25  2000/02/16  17:41:32  pjm
# it now check the project is not cancelled and the preps have not been
# cancelled.
#
# Revision 1.24  2000/02/15  15:05:45  pjm
# displays the last clone name enetered.
# volume on ligation was output on work sheet - wrong. Changed to framentation.
# vol_used
#
# Revision 1.23  2000/02/15  13:14:53  pjm
# changed text "Fragment Volume" to "DNA Vol used"
#
# Revision 1.22  2000/02/09  17:50:29  pjm
# gives preps for a given clone name that have had ligations made for it
# already (dps.STATUS in (15,20) instead of dps.STATUS = 15)
#
# Revision 1.21  2000/02/09  10:02:46  pjm
# checks DNApreps have status of 15 (assigned to subcloner). Make sure
# can't work on a prep before it has been assigned.
#
# Revision 1.20  2000/01/26  15:53:47  pjm
# prompts user if clone already has a ligation - checks they want another lig
# number
#
# Revision 1.19  2000/01/26  11:03:39  pjm
# Equus is back so code calls writeToEquus() again.
#
# Revision 1.18  2000/01/26  10:16:41  pjm
# for now took out call to writeToEquus() - Equus in bad way today!
# Added a few more set_feed_back calls to be more helpful.
#
# Revision 1.17  1999/12/15 15:00:26  pjm
# added feed_back widget to see what is slowing it down.
#
# Revision 1.16  1999/12/14 12:10:52  pjm
# now check $@ for 'Label Printer' - a non fatal error so just warn user and
# returns.
#
# Revision 1.15  1999/12/13 14:47:39  pjm
# Volume Used set in FRAGMENTATION not LIGATION now.
# Checks Vol Used is a valid number.
#
# Revision 1.14  1999/11/29 16:51:53  pjm
# defaults to d350bw if no printer choosen.
#
# Revision 1.13  1999/11/04 11:46:21  pjm
# mail was being sent to pjm - left over from debugging
#
# Revision 1.12  1999/11/03 17:32:51  pjm
# now prints out ligation labels.
# setWait called when Finished pressed.
#
# Revision 1.11  1999/10/15 15:48:58  pjm
# A '}' was in the wrong place in sub searchLigBatch. It also makes sure
# the user selects a vector before anything else. Added description of file
#
# Revision 1.10  1999/10/15 11:11:24  pjm
# added $prog         =~ s/.*\///; my $temp_file = $prog."_".......
# $0 gives full path to program
#
# Revision 1.9  1999/08/31 15:56:18  pjm
# added 'sort' on line: '-choices   => [sort keys %{$self->{operatorHash}}],'
#
# Revision 1.8  1999/08/10 16:10:58  pjm
# removed \n from subject
#
# Revision 1.7  1999/07/30 11:04:06  pjm
# removed sub showError etc, used LemurUtils versions.
# Cursor set to clock for Clone Name widget when searchForCloneName.
#
#
