#!/usr/local/bin/perl -w
#

package finishing_file_formats;
#
# Collection of routines to change between finishing file formats
#
# Ben Tubby (bt1) 25/8/00
#

BEGIN {
    unshift(@INC, "/usr/local/badger/bin");
    unshift(@INC, "."); 

    #print "\nUSING DEVELOPEMENT VERSION of finishing_file_formats.pm!!\n\n";
}

use strict;
use WrapDBI;
use Sexagesimal;

use vars qw(@ISA @EXPORT);
use Exporter;
@ISA = ('Exporter');
@EXPORT = qw(&oldfrl_to_newfrl);


sub oldfrl_to_newfrl{
    my ($oldfrl_contents, $team, $dbh) = @_;
    
    # Get database handle if we were not passed one.. 
    #
    my $we_connected;
    unless ($dbh){
        $dbh = &_OracleConnect("reports");
        $we_connected = 1;
    }

    #
    # Parse 'old-style' frl finch file and construct 'new-style' finch2 frl file.
    # NOTE: 
    # 
    # o Runtype is set to '0' for all entries
    #
    # USAGE: pass this routine a ref to an array containing the lines from an old-style frl file. eg.
    #
    # open (OLDFRL, "/nfs/admin/bt1/badger-bin/autofin.frl");
    # my @old_style_frl_contents;
    # while (<OLDFRL>){
    #     push (@old_style_frl_contents, $_);
    # }
    # close OLDFRL;
    # my $new_style_frl_contents_ref = &oldfrl_to_newfrl(\@old_style_frl_contents);
    #
    
    my $newfrl_contents;
    my $runtype_default = 0;
    my @return;
    my $no_of_primers_picked = 0;

    #
    # If we were supplied a $team, we need to use the 1:1 mapping between
    # suffix and chem_id as defined in the database...
    #
    my $output_chemid;
    if ($team){
        $output_chemid = 1;
    }else{
        $output_chemid = 0;
    }
    
    my $mapping_href;
    if ($output_chemid){
        $mapping_href = &_get_one2one_mapping_for_chem_id($team, $dbh);
        
#        my %mapping_hash = %{$mapping_href};
#        foreach my $key (keys %mapping_hash){
#            print ">$key = $mapping_hash{$key}<\n";
#        }
    }
    # Get the valid additive combos and options from the db...
    #
    my @additive_combos = &_get_oracle_additive_combos($dbh);
    my @additive_options = &_get_oracle_additive_options($dbh);

    foreach my $entry (@{$oldfrl_contents}){
        chomp $entry;
        # Skip blank lines...
        next if $entry eq "";
        next if ($entry =~/^\s+$/);
        
        my $new_entry;
        # If this line is resequence...
        #
        if     ($entry =~ /^(\S+)?       # template
                          \.(\w\w\w)?    # .suffix(3 chars)
                          (\w+)?         # OPTIONAL iteration
                          (\s+\%.*\%)?   # OPTIONAL additive info (enclosed in %%)
                          \s*$/x){       # ending in some (or no) space.
            unless ($dbh){
                die " RESEQUENCE no dbh! >$dbh<";
            }
            $new_entry = &_Create_new_style_line($1, $2, $3, undef, undef, $4, $entry, $runtype_default, 
                                                 \@additive_combos, \@additive_options, $output_chemid, $mapping_href, $dbh);
            # If this line is a Re-used primer walk...
            #
        }elsif ($entry =~ /^(\S+)?     # template
                          \.(\w\w\w)?  # .suffix(3 chars)
                          (\w+)?       # OPTIONAL iteration
                          \s+(\S+)     # primer name
                          (\s+\%.*\%)? # OPTIONAL additive info (enclosed in %%)
                          \s*$/x){     # ending in some (or no) space.
            unless ($dbh){
                die " RE-USED PRIMER no dbh! >$dbh<";
            }
            $new_entry = &_Create_new_style_line($1, $2, $3, $4, undef, $5, $entry, $runtype_default, 
                                                 \@additive_combos, \@additive_options, $output_chemid, $mapping_href, $dbh);
                        
            #
            # If this line is a New primer walk...
            #
        }elsif ($entry =~ /^(\S+)?     # template
                          \.(\w\w\w)?  # .suffix(3 chars)
                          (\w+)?       # OPTIONAL iteration
                          \s+(\S+)     # primer name
                          \s+(\S+)     # primer sequence 
                          (\s+\%.*\%)? # OPTIONAL additive info (enclosed in %%)
                          \s*$/x){     # ending in some (or no) space.
            
            unless ($dbh){
                die " NEW PRIMER no dbh! >$dbh<";
            }
            # iterate the number of primers parsed from the old-style file, 
            # so we can return it to the calling code at the end...(bt1 19/01/01)
            #
            $no_of_primers_picked++;
            $new_entry = &_Create_new_style_line($1, $2, $3, $4, $5, $6, $entry, $runtype_default, 
                                                 \@additive_combos, \@additive_options, $output_chemid, $mapping_href, $dbh);
            #################################################################################
	    # If this line *JUST* contains primer orders
	    
	} elsif ( $entry =~ /^(\S+)\s+(\S+)$/ ){      # primer name  primer sequence
            unless ($dbh){
                die " NEW PRIMER no dbh! >$dbh<";
            }
            # iterate the number of primers parsed from the old-style file, 
            # so we can return it to the calling code at the end...(bt1 19/01/01)
            #
            $no_of_primers_picked++;
            $new_entry = &_Create_new_style_line("", "", "", $1, $2, "", $entry, "", 
                                                 \@additive_combos, \@additive_options, $output_chemid, $mapping_href, $dbh);
	    #################################################################################
            # If this line didn't match any of the above, something odd has happened....
            #
        }else{
            $dbh->disconnect();
            die "\nERROR: Failed to match line;\n\n>$entry<\n\nAre you sure the readname".
                " follows the sanger naming conventions?\n\nContact bug.\n\n";
        }
        push (@return, $new_entry);
    }
    if ($we_connected){
        $dbh->disconnect();
    }
    return (\@return, $no_of_primers_picked);
    
    # New frl example contents...
    #
    # te:22cv13c10   su:r2c  pr:p1   se:GAGAGAGAGAAAA        ru:0    it:     id:     ad:
    # te:22cv15c5    su:r2c  pr:p1   se:     ru:     it:a    id:     ad:4
    # te:22cv15c5    su:r1b  pr:p1   se:     ru:     it:a    id:13   ad:5
    # te:22cv13c10   su:s2t  pr:     se:GATTAGAGAGG  ru:0    it:     id:46   ad:6
    # te:22cv13c10   su:s2t  pr:p1   se:GAGAGAGAGAAAA        ru:0    it:     id:46   ad:6
    # te:22cv15c5    su:s2t  pr:p1   se:     ru:     it:     id:46   ad:6
    # te:22cv15c5    su:r1b  pr:p1   se:     ru:0    it:     id:13   ad:6
}
##########################################################################################
sub _Create_new_style_line{
    my ($template, $suffix, $iteration, $oligoname, $oligo_sequence, 
        $ad, $line_from_frl, $runtype_default, $additive_combos_aref, 
        $additive_opts_aref, $output_chemid, $mapping_href, $dbh) = @_;
    
    # If we were passed additive info...
    my $id;
    if ($ad){
        if ($ad =~ /\s+\%(\D+)\%/){
            # If additive field is NOT NUMERIC....
            #
            my $additive_string = $1;
            # make a copy of the additive string, so we can remove the optional trailing 'dGTP' and check the Additives
            my $additive_combo = $additive_string;
            $additive_combo =~ s/\s+dGTP//;
            #print "\nadditive_combo is now >$additive_combo< >$additive_string<\n"; 
            
            if ($additive_combo){
                # Only do this if we have an additive combo (i.e. not JUST the string 'dGTP')
                my $c;
                foreach (@{$additive_combos_aref}){
                    if ($additive_combo=~ /^$_$/){
                        #print "VAILD!!!!!";
                        $c++;
                    }
                }
                if (! $c){
                    die "\nERROR: The additive combo \'$additive_combo\' in the line;\n\n".
                        "\'$line_from_frl\'\n\n".
                        "is INVALID!  ".
                        "Valid options are (". join (", ", @{$additive_combos_aref}). ")...\n".
                        "If you think this is incorrect, please mail bug...\n";
                }
            }
            $id = &_return_additiveid_from_description($additive_opts_aref, $additive_string, $dbh);
            
        }elsif ($ad =~ /\s+\%(\d+)\%/){
            #
            # If additive field IS NUMERIC...
            #
            my $additive_id = $1;
            # Check that it is valid;
            # my @additive_options = &_get_oracle_additive_options($dbh);
            
            my $c;
            foreach (@{$additive_opts_aref}){
                if ($additive_id=~ /^$_$/){
                    #print "VAILD!!!!!";
                    $c++;
                }
            }
            if (! $c){
                die "\nERROR: The additive id \'$additive_id\' in the line;\n".
                    "\'$line_from_frl\'\n\n".
                    "is INVAID!  ".
                    "Valid options are (". join (", ", @{$additive_opts_aref}). ")...\n".
                    "If you think this is incorrect, please mail bug...\n";
            }
            $id = $1;
        }
    }
    
    #
    # Define undef variables to keep perl happy...
    #
    $template       = " " unless ($template);
    $suffix         = " " unless ($suffix);
    $iteration      = " " unless ($iteration);
    $oligoname      = " " unless ($oligoname);
    $oligo_sequence = " " unless ($oligo_sequence);
    $id             = " " unless ($id);
    
    my ($string, $chem_id);
    if ($output_chemid){
        # If we were passed a teamname, we need to output the 1:1 mapping of suffix:chem_id...
        my %mapping_hash = %{$mapping_href};
        
        # Add a dot to the suffix so we can match the entry in the hash...
        my $s = ".$suffix";
        $chem_id = $mapping_hash{$s};
    }        
    if ($chem_id){
        $string = sprintf "%-20s %-10s %-10s %-10s %-30s %-10s %-10s %-10s" , 
                          "te:$template", "su:$suffix", "it:$iteration", "pr:$oligoname", 
                          "se:$oligo_sequence", "ru:$runtype_default", "ad:$id", "id:$chem_id";
    }else{
        # Output the string minus the chem id...
        $string = sprintf "%-20s %-10s %-10s %-10s %-30s %-10s %-10s" , 
                          "te:$template", "su:$suffix", "it:$iteration", "pr:$oligoname", 
                          "se:$oligo_sequence", "ru:$runtype_default", "ad:$id";
    }
    return $string;
}
##########################################################################################
sub _get_oracle_additive_options{
   my ($dbh) = @_;
   
   my ($ref, $id);
   eval{
       $ref = $dbh->fetch_all(qq[
                                 select id_additive
                                 from additive]
                              );
   };
   if ($@){
       die  "\nERROR: An database I/O error occured!\n$@\n";
   }
   my @array;
   foreach (@{$ref}){
       push @array, @{$_};
   }
   return @array;
}
##########################################################################################
sub _get_oracle_additive_combos{
    my ($dbh) = @_;
  
    my ($ref, $id);
    eval{
        $ref = $dbh->fetch_all(qq[
                                  select description
                                  from additive]
                               );
    };
    if ($@){
        die  "\nERROR: A database I/O error occured!\n$@\n";
    }
    my @array;
    foreach (@{$ref}){
        push @array, @{$_};
    }
    return @array;
}
##########################################################################################
sub _OracleConnect {
    my ($oracle_user) = @_;
    
    my $dbh = WrapDBI->connect($oracle_user, {RaiseError => 1, AutoCommit=> 0} );
    die "Could not connect to database" if (!defined $dbh);
    return $dbh;
}
##########################################################################################
sub _return_additiveid_from_description{
    my ($additive_options, $additives, $dbh) = @_;
    
    #  Called when a non-numeric additive field is detected...
    my ($add_a, $add_e, $add_f);
    my %hash;
    my $dgtp = 0;

    # Parse additive field
    if ($additives =~ /dGTP$/){
        #print "\no Removing 'dGTP'...\n";
        $additives =~ s/(\s+)?dGTP//;
        $dgtp = 1;
    }
    
    my $string;
    # foreach additive specified
    my $length = length $additives;
    if ($additives){
        for (my $i = 1; $i <= $length; $i++){
            $additives =~ s/(\S)$//; # match last additive and remove it
            $hash{$1} = 1;
            
            $string .= "$1 = 1 and ";
        }
    }
    
    #
    # Foreach of the valid additives, if it's not been specified, then we must add
    # 'additive = 0' to the string.
    #
    # BAD hardcoded additives.  needs fixing.
    #

    my @valid_additives = &_get_all_valid_additives($dbh);

    foreach my $add (@valid_additives){
        # foreach my $add ('A', 'E', 'F', 'B', 'C', 'D', 'G', 'H', 'M'){
    #        print "\n>$add< ";
    #        print "NEED TO ADD >$add<" unless ($hash{$add}); 
        $string .= "$add = 0 and "unless ($hash{$add});
    }
    
    if ($dgtp){
        $string .= "DGTP = 1";
    }else{
        $string .= "DGTP = 0";
    }
    $string =~ s/and $//; #Remove last 'and'

   # print ">>>>>>$string<<<<<\n";
    #die;
    my ($ref, $id);
    eval{
        ($id) = $dbh->fetch_row(qq[
                                   select id_additive
                                   from additive 
                                   where $string]
                                );
        if (! $id){
            # If no id was returned...
            die "\n\nNo additive_id was returned from the 'additive' table in Oracle\nfor >$string<.".  
                "  CONTACT BUG...\n\n";
        }
    };
    if ($@){
        die  "\n\nERROR: A database I/O error occured!\n$@\n\n";
    }
    return $id;
}
###############
###############
###############

sub FIN_parse_staden_output{
    my ($suffix_type,
        $do_primers, $do_longreads, $do_resequences, # these 3 variables control what is parsed from staden output...
        $frlfile,                                    # old style frl-file to create
        $frlfile2,                                   # new style frl-file to create
        $primerprefix,                               # prefix for primernames
        $staden_p_fh,                                # filehandle to read parsed staden output file from
        $debug,
        $project,                           
        $registeryesorno,                            #flag to say if we want to try and register this project in autoprimername.
        $dbh,                                        # database handle
	$base
        ) = @_;
    
    #
    # Routine to convert the CURRENT (November 2000) Staden finishing code output into sanger
    # format frl files (both old 'finch' and new 'crusade' sytle).  The filenames to be used
    # are passed in, as is an open filehandle pointing at the parsed staden output file.
    # SEE AUTOFINISH CODE FOR EXAMPLE OF USE....
    #
    
    # $base is optional. Treat as base 10 if not specified.
    if (!defined $base) {
	$base = 10;
    }

    print "Base=$base\n";

    # Cached SQL query to check if a read iteration is needed.
    my $sql = qq[select count(*)
		 from   seqread sr
		 where  sr.name = ?];
    my $check_iter_exists = $dbh->prepare($sql);

    # Set input file separator so each FILE loop receives 1 EXPERIMENT block
    local $/ = "EXPERIMENT";
    
    my $starting_primer = 1;
    if ($registeryesorno){
        #
        # Try to register $project in the AUTOPRIMERNAME table...
        #
        print "* Attempting to register $project in autoprimername...  ";
        ($starting_primer) = &register_project_in_autoname($project, $primerprefix, $dbh);
    }
    my $next_primer = $starting_primer;
    
    # then, for each primer picked, get the name from the table and increment next_val.
    # $next_primer will come from oracle.
    #

    my %primers;
    my $old_primer = "";
    my @old_format_frl;
    
    open (FRL,    ">$frlfile")  || die "Failed to open $frlfile for writing $!\n";
    open (NEWFRL, ">$frlfile2") || die "Failed to open $frlfile for writing $!\n";
    while (<$staden_p_fh>){
        print "\n-----------------------------------------\n" if ($debug);
        my $experiment; #start a new experiment in the data structure
        # one whole experiment is entered into 1 element of the array...
        my @lines = split "\n", $_;
        foreach my $line (@lines){
            my $frl_line;
            if ($do_primers){
                ($next_primer, $old_primer, $frl_line) = &_primer($suffix_type, \@lines, \*FRL, \%primers, $old_primer, 
                                                                  $next_primer, $primerprefix, $debug, $project, 
                                                                  $registeryesorno, $dbh, $base)   if ($line =~ /Primer walk/);
            }
            # We can use the same routine for these 2, as the block structure is the same.
            #
            if ($do_longreads){
                ($frl_line) = &_longread(\@lines, \*FRL, $check_iter_exists, $debug) if ($line =~ /Long gel reading/);
            }
            if ($do_resequences){
                ($frl_line) = &_longread(\@lines, \*FRL, $check_iter_exists, $debug) if ($line =~ /Resequence/);
            }
            push (@old_format_frl, $frl_line) if ($frl_line);
        }
        next;
    }   
    print "\n\n";
    # Create new-style frl...
    eval{
        # Hardcoded '71' 29/11/00 to ensure we correctly convert suffix to chemid (id_scsp) (see dn1)
        #
        my ($new_style_frl_contents_ref, $no_primers_parsed) = &oldfrl_to_newfrl(\@old_format_frl, 71, $dbh);
        foreach my $line (@{$new_style_frl_contents_ref}){
            print NEWFRL "$line\n";
        }
    };
    close NEWFRL || die "Failed to close filehandle $!\n";

    $check_iter_exists->finish();

    if ($@){
        die ">$@";
    }
    # Return the primer_sequence -> primer_name hash (so we can add the names to the tags file later)
    # and the number of primers that were picked this round...
    #
    my $no_primers_picked = $next_primer-$starting_primer;
    return (\%primers, $no_primers_picked);
}
#############################################
sub register_project_in_autoname{
    my ($project, $primerprefix, $dbh) = @_;
    my $already_registered = 0;
    
    #
    # Check if it's sven worth continuing.  If this project isn't in the project
    # table, registration will fail...
    #
    my $result;
    eval{
        ($result) = $dbh->fetch_scalar(qq[
                                          select projectname
                                          from PROJECT
                                          where projectname = '$project'
                                          ]);
    };
    unless ($result){
        print "ERROR: Failed to find an entry for >$project< in the PROJECT table....\n".
            "Autoprimername update will fail.\n";
        return;
    }
    # We need to check if this project has already been registered...
    my $next_val;
    eval{
        ($next_val) = $dbh->fetch_scalar(qq[
                                            select NEXT_VAL
                                            from autoprimername
                                            where projectname = '$project'
                                            ]);
    };
    if ($@){
        warn  "Oracle problem!\n$@";
    }
    if ($next_val){
        print "FAILED. $project has been previously registered.\n";
        $already_registered = 1;
    }else{
        print "DONE.\n";
        $next_val = 1;
    }
    print "\n-->NEXT AVAILABLE PRIMER NO: $next_val<--\n";
    unless ($already_registered){
        eval{
            my $sql = "insert into autoprimername
                        (        PROJECTNAME, ROOT,              NEXT_VAL)
                        values ('$project',  '$primerprefix',    1)";
            $dbh->do(qq[$sql]);
            print "\n>>$sql<<\n";
        };
        if ($@){
            $dbh->rollback;
            warn  "Problem registering $project in the autoprimername table ('$project',  '$primerprefix', 1)\n$@";
            &Mail("finish_me error..",
                  "\n\nProblem registering project in the autoprimername table\n\n$@\n\n",
                  "dn1g");
        }else{
            print "Committing to database...\n";
            $dbh->commit;
        }
    }
    return ($next_val);
}
#######################
sub increment_primer_in_db{
    my ($project, $val, $dbh) = @_;
    
    eval{
        print "Incrementing primer to $val...\n";
        my $smt = "update autoprimername
                   set next_val = $val
                   where projectname = '$project'";
        $dbh->do(qq[$smt]);
    };
    if ($@){
        $dbh->rollback;
        die  "Problem updating $project row in the autoprimername table\n$@";
    }else{
        $dbh->commit;
    }
}
###########################
sub _primer{
    my ($suffix_type, $experiment_aref, $fh, $primers_href, $old_primer, $count, 
        $primerprefix, $debug, $project, $registeryesorno, $dbh, $base) = @_;
    # $suffix_type is the final letter on the suffix to be created
    
    my ($seq, $temp, $primerno, $definedTemplate, $definedPrimer, $alreadyPrintedExperiment, $foundNewPrimer);
    my $experiment;
    my $frl_line;
    my $template_direction;
    my $sth = $dbh->prepare(qq[select 1 from primer where primername = ? and projectname = ?]);
    
    # If this entry is a primer walk....
    foreach my $line (@{$experiment_aref}){
        chomp $line;
        if ($line =~ /^=== Primer sequence (\S+)/){
            $seq = $1;
            $definedTemplate = 1;
            #  print ">$seq, >$count<<\n";
            # Check if this is a new primer (not used in any experiments yet...)
            if ($old_primer ne $seq){
		my $primer_duplicated;
		do {
		    $primerno = $count;
		    #print "****   Found NEW Primer ($seq) ($primerno) oldprimer = >$old_primer<*****\n";
		    if ($base == 60) {
			my $primerno60 = int2sexa($primerno);
			$primers_href->{$seq} = $primerprefix.$primerno60;
		    } else {
			$primers_href->{$seq} = $primerprefix.$primerno;
		    }
		    # Check if it already exists
		    $sth->execute($primers_href->{$seq}, $project);
		    undef($primer_duplicated);
		    ($primer_duplicated) = $sth->fetchrow_array();
		    $count++; # increment the primer no.
		    if ($registeryesorno) {
			&increment_primer_in_db($project, $count, $dbh);
		    }
		    if (defined($primer_duplicated)) {
			print "Primer $primers_href->{$seq} already used\n";
		    }
		    print "old primer now = ($seq)\n" if ($debug);
		    $old_primer     = $seq;
		    $foundNewPrimer = 1;
		} while (defined($primer_duplicated));
            }else{
                $primerno = $count;
                print "* Reusing old primer ($seq)..." if ($debug);
            }
        }
        if ($line =~ /^=== Template name (\S+)/){
            $definedPrimer = 1;
            $temp = $1;
            $alreadyPrintedExperiment = 0;
        }
        if ($line =~ /^=== Template direction\s(\S)\s\S+/){
            $template_direction = $1;
            #print "\nmatched TEMPLATE DIRECTION... $line >$1<";
            $experiment->{template_direction} = $1;
        }
        
        # Primer direction added to output file (bt1 23/4/01)
        # need to parse this line from each experiment;
        # === Primer score=16.000001, direction '+'
        if ($line =~ /^=== Primer score\S+\s+\S+\s+\'([+-])\'/){
            $experiment->{primer_direction} = $1;
            
            my $pd = $experiment->{primer_direction} eq '+' ? 1 : -1;
            my $td = $template_direction             eq '+' ? 1 : -1;
            
            my $new_read_dirn = $pd * $td;
            $experiment->{orient_suffix} = $new_read_dirn == 1 ? ".p2".$suffix_type : ".q2".$suffix_type;
        }
        unless (($definedTemplate) && ($definedPrimer) && ($experiment->{orient_suffix})){
            print "\ntemplate and primer and direction not defined for this experiment.  Checking next line...\n" if ($debug);
            next;
        }else{
            # Store experiment information in memory
            $experiment->{template} = $temp;
            $experiment->{sequence} = $seq;
            $experiment->{primerno} = $primers_href->{$seq};
            
            # Print frl line to file.
            unless ($alreadyPrintedExperiment){
                print $fh "\n$experiment->{template}"."$experiment->{orient_suffix}\t"."$experiment->{primerno}\t";
                print $fh "$experiment->{sequence}" if ($foundNewPrimer);
                
                $frl_line  = "$experiment->{template}"."$experiment->{orient_suffix}\t"."$experiment->{primerno}\t";
                $frl_line .="$experiment->{sequence}" if ($foundNewPrimer);
            }
            # so we don't print this more than once...
            $alreadyPrintedExperiment = 1;
        }
    }

    $sth->finish();
    print "DEBUG: ".$experiment->{template}.$experiment->{orient_suffix}.$experiment->{primerno}.
          " Primer Direction = $experiment->{primer_direction}, Template orientation = $experiment->{template_direction}<\n" if ($debug);
    return ($count, $old_primer, $frl_line);
}

#################################################################################################
sub _longread{
    my ($experiment_aref, $fh, $check_iter_exists, $debug) = @_;
    
    # === EXPERIMENT 217/47: pos 3017-3717
    # === Score: 383.540037
    # === Chemistry 7
    # === Template name 23bA93B10-7f02
    # === Type Long gel reading
    # === Direction -
    
    my ($template, $name, $alreadyrintedExperiment);
    my $frl_line;
    
    # If this entry is a longread...
    foreach my $line (@{$experiment_aref}){
	if ($line =~ /^=== Reading name (\S+)/){
	    $name = $1;
	}
	    
	unless ($name){
	    #print "\ntemplate and primer not defined for this experiment.  Checking next line...\n" if ($debug);
	    next;
	}else{
	    #my $suffix;
	    #$suffix = ".q1?" if ($direction eq "-");
	    #$suffix = ".p1?" if ($direction eq "+");
	    unless ($alreadyrintedExperiment){
		my $iter;
		
		for ($iter = "a"; ; $iter++) {
		    my $n = "$name$iter";
		    $check_iter_exists->execute($n);
		    my ($count) = $check_iter_exists->fetchrow_array();
		    if ($count == 0) { last; }
		}
		print $fh "\n$name$iter";
		$frl_line  ="$name$iter";
	    }
	    $alreadyrintedExperiment = 1;
	}
    }
    return ($frl_line);
}
###################################################################################

sub _get_one2one_mapping_for_chem_id{
    my ($team, $dbh) = @_;
    
    my ($ref);
    eval{
        $ref = $dbh->fetch_all(qq[select SUFFIX, ID_SCSP
                                  from team_chempref where teamname = $team
                                  ]);
    };
    if ($@){
        die  "\nERROR: A database I/O error occured!\n$@\n";
    }
    
    my %hash_of_mapping;
    
    foreach my $aref (@{$ref}){
        $hash_of_mapping{${$aref}[0]} = ${$aref}[1];
    }
    return \%hash_of_mapping;
}

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

sub _get_all_valid_additives{
    my ($dbh) = @_;
    
    my $ref;
    eval{
        $ref = $dbh->fetch_all(qq[
                                  select column_name
                                  from all_tab_columns
                                  where owner    = 'TRACKING'
                                  and table_name = 'ADDITIVE'
                                  and column_name not in ('ID_ADDITIVE', 'DESCRIPTION', 'DGTP')
                                  ]);
    };
    if ($@){
        die  "\nERROR: A database I/O error occured!\n$@\n";
    }
    
    my @array;
    foreach (@{$ref}){
        push @array, @{$_};
    }
    return @array;
}

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


sub consed9_output_to_sanger{
    my ($outputfile, $customPrimers, $univForwards, $univReverses) = @_;
    
    my $writetofile = 1;
    
    my $primername                 = "A";
    my $fwdprimersuffix            = "p1c";
    my $revprimersuffix            = "q1c";
    my $fwdcustprimersuffix        = "p2c";
    my $revcustprimersuffix        = "q2c";
    my $consed_noncustom_iteration = "z";
    
    open (FRLFILE, ">$outputfile") || die ("\nCouldn't open $outputfile\n$!\n") if ($writetofile);
    
    print "o Examining the consed output files\n($customPrimers, $univForwards, $univReverses)...\n";
    foreach my $file ($customPrimers, $univForwards, $univReverses){
        my @array;
        print "\no Opening $file...\n";
        open (FILE, "$file") || die ("\nCouldn't open $file\n$!\n");
        
        if ($file eq $customPrimers){
            print "\n";
            my $lines_in_file;
            my $lines_parsed;
            my %seenthis;
            while (<FILE>){
                $lines_in_file++;
                
                if ($_ =~ /^([gact]+),\d+,(\S+.\d+),\S+,\S+,\S+,\S+,(Contig\d+),\d+,(.+)$/){    
                    # we can't use \d+ in the above pattern match, as fields may contain minus sign
                    
                    my $sequence  = uc($1);
                    my ($projectname, $primerno) = split /\./, $2;
                    my $name = $primername.$primerno;
                    my $contig    = $3;
                    my @templates = split ",",$4;
                    
                    foreach my $template (@templates){
                        next if ($template =~ /^\d+$/); # We don't need the consed template exp id's
                        if ($template =~ /(\S+)\s+\((\S+)\)/){ # dJ575N6Ag8 (rev)
                            $lines_parsed++;
                            print "$1.".$fwdcustprimersuffix if ($2 eq "fwd");
                            print "$1.".$revcustprimersuffix if ($2 eq "rev");
                            print "\t$name";
                            print "\t$sequence" unless $seenthis{$name};
                            print "\n";
                            
                            # and to file...
                            if ($writetofile){
                                print FRLFILE "$1.".$fwdcustprimersuffix if ($2 eq "fwd");
                                print FRLFILE "$1.".$revcustprimersuffix if ($2 eq "rev");
                                print FRLFILE "\t$name";
                                print FRLFILE "\t$sequence" unless $seenthis{$name};
                                print FRLFILE "\n";
                            }
                            # mark oligoname off as seen, so we only get the sequence printer once...
                            $seenthis{$name} = 1; 
                        }
                    }
                }
            }
            print "\no Parsed $lines_parsed suggested experiments from $file (containing $lines_in_file lines).\n";
        }
        
        if ($file eq $univForwards){
            my $lines_in_file;
            my $lines_parsed;
            while (<FILE>){
                $lines_in_file++;
                if ($_ =~ /univ fwd,,,\S+,\d+,\d+,\d+,Contig\d+,\d+,(\S+)/){
                    $lines_parsed++;
                    print "\n$1.".$fwdprimersuffix.$consed_noncustom_iteration; 
                    
                    # and to file...
                    if ($writetofile){
                        print FRLFILE "\n$1.".$fwdprimersuffix.$consed_noncustom_iteration; 
                    }
                }
            }
            print "\n\no Parsed $lines_parsed suggested experiments from $file (containing $lines_in_file lines).\n";
        }
        
        if ($file eq $univReverses){
            my $lines_in_file;
            my $lines_parsed;
            while (<FILE>){
                $lines_in_file++;
                if ($_ =~ /univ rev,,,\S+,\d+,\d+,\d+,Contig\d+,\d+,(\S+)/){
                    $lines_parsed++;
                    print "\n$1.".$revprimersuffix.$consed_noncustom_iteration; 
                    
                    # and to file...
                    if ($writetofile){
                        print FRLFILE "\n$1.".$revprimersuffix.$consed_noncustom_iteration; 
                    }
                }
            }
            close FRLFILE if ($writetofile);
            print "\n\no Parsed $lines_parsed suggested experiments from $file (containing $lines_in_file lines).\n";
        }
        print "*"x100;
    }
    return;
}


##############################################################################
sub Mail{
    my ($subject, $message, $who_to_mail) = @_;

    print "ERROR: Error opening pipe to /usr/lib/sendmail\n\n" unless open (SENDMAIL, "| /usr/lib/sendmail -t -n");
    print SENDMAIL <<EOM;
To: $who_to_mail
Cc: 
Subject: $subject

$message

EOM
    close(SENDMAIL);
}
1;

__END__

# Logs start here;
#    
# $Id: finishing_file_formats.pm,v 1.59 2004/09/29 10:18:11 jkb Exp $
#
# $Log: finishing_file_formats.pm,v $
# Revision 1.59  2004/09/29  10:18:11  jkb
# Added reading name iterations to _longread() so that resequence
# requests pick the appropriate iterations to put in the frl files.
#
# Revision 1.58  2004/08/16 15:58:32  jkb
# Changed oldfrl_to_newfrl so that names such as eimer-801e04.q1kaw are
# still considered as legal (previously .q1k or .q1ka were valid, but
# not .q1kaw).
#
# Revision 1.57  2003/11/14 09:49:08  jkb
# Check is primer name already exists, and if so skip to the next one.
#
# Revision 1.56  2003/10/08  13:38:22  jkb
# Added "local" to $/ assignment in FIN_parse_staden_output. It was
# wrecking code use elsewhere and functions should not have such
# external side effects.
#
# Revision 1.55  2003/09/22  16:47:26  jkb
# Added an optional $base parameter to FIN_parse_staden_output. Defaults
# to 10, and only supports 10 and 60. With base 60 the sexagesimal
# string form is used to reduce then length of primer names giving
# 216000 names in 4 characters ("A***") instead of just 1000.
#
# Revision 1.54  2002/02/13  10:28:24  bt1
# *** empty log message ***
#
# Revision 1.53  2002/02/13  10:06:51  bt1
# Altered default suffix for autopicked reads from .XXc to .XXk
#
# Revision 1.52  2002/01/15  15:15:33  bt1
# *** empty log message ***
#
# Revision 1.51  2001/12/18  09:53:33  bt1
# *** empty log message ***
#
# Revision 1.50  2001/12/13  16:52:11  bt1
# *** empty log message ***
#
# Revision 1.49  2001/12/13  16:46:59  bt1
# *** empty log message ***
#
# Revision 1.48  2001/12/13  16:44:27  bt1
# *** empty log message ***
#
# Revision 1.47  2001/12/13  16:10:55  bt1
# *** empty log message ***
#
# Revision 1.46  2001/12/13  16:08:28  bt1
# *** empty log message ***
#
# Revision 1.45  2001/12/13  15:35:57  bt1
# *** empty log message ***
#
# Revision 1.44  2001/12/13  15:20:01  bt1
# *** empty log message ***
#
# Revision 1.43  2001/12/13  13:06:12  bt1
# *** empty log message ***
#
# Revision 1.42  2001/12/13  12:56:00  bt1
# *** empty log message ***
#
# Revision 1.41  2001/12/13  12:44:48  bt1
# *** empty log message ***
#
# Revision 1.40  2001/12/13  12:32:15  bt1
# *** empty log message ***
#
# Revision 1.39  2001/12/13  09:34:55  bt1
# *** empty log message ***
#
# Revision 1.38  2001/12/13  08:25:48  bt1
# Added some logic to ensure the suffix given to new primer reads
# is consistent with both the direction of the oligo it was primed
# from, and the orientation of the template in the gap database...
#
# Revision 1.37  2001/11/15  17:27:20  bt1
# Updated starting primer inFIN_parse_staden_output to 1.
#
# Revision 1.36  2001/09/11  14:53:32  bt1
# *** empty log message ***
#
# Revision 1.35  2001/06/28  11:36:37  bt1
# *** empty log message ***
#
# Revision 1.34  2001/06/05  11:11:24  bt1
# *** empty log message ***
#
# Revision 1.33  2001/06/04  11:31:30  bt1
# *** empty log message ***
#
# Revision 1.32  2001/06/04  11:26:42  bt1
# *** empty log message ***
#
# Revision 1.31  2001/06/04  11:20:24  bt1
# *** empty log message ***
#
# Revision 1.30  2001/03/30  09:56:54  bt1
# *** empty log message ***
#
# Revision 1.29  2001/03/28  14:45:57  dn1
# *** empty log message ***
#
# Revision 1.28  2001/03/28  14:45:39  dn1
# *** empty log message ***
#
# Revision 1.27  2001/03/27  08:45:12  bt1
# *** empty log message ***
#
# Revision 1.26  2001/03/08  12:29:08  bt1
# *** empty log message ***
#
# Revision 1.25  2001/03/08  12:09:36  bt1
# fixed typo
#
# Revision 1.24  2001/03/08  12:08:12  bt1
# added $registeryesorno flag to FIN_parse_staden_output routine.
#
# Revision 1.23  2001/03/07  17:48:30  bt1
# changed the die to a warn if the eval around registering the
# project in the autoprimername table fails
#
# Revision 1.22  2001/03/01  15:59:32  bt1
# *** empty log message ***
#
# Revision 1.21  2001/03/01  15:54:10  bt1
# *** empty log message ***
#
# Revision 1.20  2001/03/01  15:49:37  bt1
# altered pattern matched to handle a '.' as the template name
#
# Revision 1.19  2001/03/01  15:33:06  bt1
# Added dbh->disconnect is we die
#
# Revision 1.18  2001/02/28  09:55:46  bt1
# altered pattern match
#
# Revision 1.17  2001/02/28  09:07:05  bt1
# skip all blank lines
#
# Revision 1.16  2001/02/02  11:28:22  bt1
# added disconnectionn from oracle (if we connected in this session..)
#
# Revision 1.15  2001/01/25  13:02:01  bt1
# removed debugging print...
#
# Revision 1.14  2001/01/25  12:49:45  bt1
# removed debug print
#
# Revision 1.13  2001/01/25  11:35:05  bt1
# Added consed9_output_to_sanger routine to parse Mr Gordon's Consed output
#
# Revision 1.12  2000/11/13  12:19:20  bt1
# removed debugging print
#
# Revision 1.11  2000/11/13  12:17:35  bt1
# Added code to output the teamspecific 1:1 mapping from suffix:chem_id
# from oracle (&_get_one2one_mapping_for_chem_id)...
# Also removed hardcoded valid additives.  These are now returned from the
# database (see &_get_all_valid_additives)...
#
# Revision 1.10  2000/11/07  16:30:15  bt1
# temp fix to get current datbase-valid additive info parsing working.
# Will break once multiple additives are allowed to be combined in the
# database.  I'll fix that next week...
#
# Revision 1.9  2000/11/06  14:28:51  bt1
# removed debugging print...
#
# Revision 1.8  2000/11/06  14:26:58  bt1
# Added routine to convert CURRENT staden finishing output into sanger frl-style files.
# Not sure if this should really go here, as it's a tad difficult to use.
# It is also prone to changing as staden decide to alter the format of their output
# file.
#
# Revision 1.7  2000/11/02  10:57:22  bt1
# changed to get valid db additive combos and id's ONCE at the beginning...
#
# Revision 1.6  2000/11/01  16:51:44  bt1
# fixed bug.
#
# Revision 1.5  2000/11/01  16:43:50  dn1
# *** empty log message ***
#
# Revision 1.4  2000/11/01  16:31:53  dn1
# fixed bu te: etc
#
# Revision 1.3  2000/11/01  16:05:00  bt1
# Added Package namespace
# Added use of exporter
# Added ability to be passed an open database handle (dbh)
# Removed all exits.  Changed to dies so they can be caught with eval.
#
# Revision 1.2  2000/10/25  16:16:44  bt1
# Added RCS logging to end of code
#
#





















