# $Id: LemurUtils.pm,v 1.14 2000/11/01 17:30:19 pjm Exp $
#
# holds common functions for other Lemur modules.
#


package LemurUtils;

use strict;
use Tk::Dialog;
use POSIX qw(strtod);                     # string to digit? See isValidNumbr()


################################################################################
# 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, $refToHash) = @_;
    my (@vector_list)      = sort keys %{$refToHash};

    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;
}


# set the colours for BrowseEntry widgets (the Entry widget within it).
#    . LemonChiffon2 for required field
#    . LightGrey for optional field

sub setBrowseEntryLemon {
    my ($type, $widget) = @_;

    my $e = $widget->Subwidget("entry")->Subwidget("entry");
    $e->configure(-bg => 'LemonChiffon2');
}

sub setBrowseEntryGrey {
    my ($type, $widget) = @_;

    my $e = $widget->Subwidget("entry")->Subwidget("entry");
    $e->configure(-bg => 'LightGrey');
}


################################################################################
# sets the cursor to a watch
#
# THIS DON' WORK FOR ENTRY WIDGETS - CAN'T SET CURSOR
# MAY HAVE TO WRITE NewEntry.pm
#
################################################################################

sub setWait {

    my ($type, $windows) = @_;

    foreach (@{$windows}) {
        $_->configure(-cursor => 'watch');
	$_->update();
    }
}

#
# sets the cursor back to an arrow
#

sub unSetWait {
    my ($type, $windows) = @_;

    foreach (@{$windows}) {
        $_->configure(-cursor => 'top_left_arrow');
	$_->update();
    }
}

################################################################################
# shows error dialog box
################################################################################

sub showError {
    my ($type, $window, $message) = @_;
#    warn "ERROR: $message\n";

    my $dialog = $window->Dialog (-title          => "Error",
				  -text           => "$message",
				  -default_button => 'Ok',
				  -buttons        => ['Ok']);
    $dialog->Show();
    $dialog->destroy();
}


################################################################################
# shows an info box.
################################################################################

sub showInfo {

    my ($type, $window, $message) = @_;

    my $dialog = $window->Dialog (-title          => "Message",
				  -text           => "$message",
				  -default_button => 'Ok',
				  -buttons        => ['Ok']);
    $dialog->Show();
    $dialog->destroy();
}

sub yesNo {
    my ($type, $window, $message) = @_;

    my $dialog = $window->Dialog (-title          => "Are You Sure?",
				  -text           => "$message",
				  -default_button => 'No',
				  -buttons        => ['Yes', 'No']);
    my $ans = $dialog->Show();
    $dialog->destroy();
    return $ans;
}

################################################################################
# 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;

	$day   =~ s/^0//; # get rid of zero's - 02/02/1999. Will screw up
	$month =~ s/^0//; # hash look up later


	# check year

	if($year < 1999) { # year this code 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;
}

################################################################################
# returns 1 if is POSIX number, 0 if not.
# valid   examples inlcude: '1', '1.1', '0.' and '1.'
# invalid examples include: ' 1.1.1'  
################################################################################

sub isValidNumber {
    my ($self, $number) = @_;

    $number  =~ s/^\s+//;
    $number  =~ s/\s+$//;

    $!= 0;
    my ($num, $unparsed) = strtod($number); # POSIX sys call, returns num

    if( ($number eq '') || ($unparsed != 0) || $!  ) {
        return 0;
    }

    return 1;
}

###########
#########
#
# DB queries only below here please!
#
#########
###########

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

    return $dbh->fetch_scalar(qq[select sj.ID_REQUEST
                                 from   LIGATION l, FRAGMENTATION_BAND fb,
                                        SIL_JOB sj
                                 where  l.ID_LIGATION = $id_ligation
                                 and    l.ID_FRAGBAND = fb.ID_FRAGBAND
                                 and    fb.ID_FRAG    = sj.ID_FRAG ]);
}

################################################################################
# returns full user name from email initails eg 'pjm' gets you 'Paul Mooney'
################################################################################

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

    return $dbh->fetch_scalar(qq[select FORENAME || ' ' || SURNAME
                                 from   PERSON
                                 where  EMAIL = '$email' ]);
}

# 'pjm' returns you 4004
#
sub get_id_person_from_email_name {
    my ($self, $dbh, $email) = @_;

    return $dbh->fetch_scalar(qq[select ID_PERSON
                                 from   PERSON
                                 where  EMAIL = '$email' ]);
}

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

    return 10581 if $email eq 'pjm'; # SO pjm CAN USE LIVE VERSION !

    return $dbh->fetch_scalar(qq[select tpr.ID_ROLE
                                 from   TEAM_PERSON_ROLE tpr, PERSON p
                                 where  p.EMAIL       = '$email'
                                 and    p.ID_PERSON   = tpr.ID_PERSON
                                 and    tpr.ROLETYPE  = 'Subcloning'
                                 and    tpr.ISCURRENT = 1
                                 ]);
}

# return's 1 if valid clone name
#
sub is_valid_clone_name {
    my ($self, $dbh, $clone_name) = @_;

    my $name = $dbh->fetch_scalar(qq[
                                     select CLONENAME
                                     from   CLONE
                                     where  CLONENAME = '$clone_name'
                                     ]);
    if( $name ){
        return 1;
    }
    else{
        return 0;
    }
}

################################################################################
# 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");

    foreach $arrayRef (@$arrayOfArrays) {

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

	$vectors{$name}->{ID_VECTORSITE} = $arrayRef->[2];
    }

    return \%vectors;
}

################################################################################
# setup array with list of possible vectors. Put pUC & m13 at top.
# Only vectors that have enzymes to cut them should be shown.
################################################################################

sub getVectors {
    my ($self, $dbh) = @_;
    my ($arrayOfArrays, $arrayRef);
    my @vectors;
    my %isInArray;
    my $vectorName;

    $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"); 
 
    foreach $arrayRef (@$arrayOfArrays) {
	$vectorName = $arrayRef->[0];

	unless( $isInArray{$vectorName} ) {

	    $isInArray{$vectorName} = 1;
	    push(@vectors, $vectorName);
	}
    }

    return \@vectors;
}

################################################################################
# setup $self->{operatorHash}
################################################################################

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

    $arrayOfArrays =
        $dbh->fetch_all(qq[
                           select p.ID_PERSON, p.FORENAME, p.SURNAME,
                                  p.EMAIL
                           from   PERSON p, TEAM_PERSON_ROLE tpr
                           where  tpr.ROLETYPE  = 'Subcloning' 
                           and    tpr.ID_PERSO  = p.ID_PERSON
                           and    tpr.ISCURRENT = 1
                           and    p.ISCURRENT   = 1
                           ]); 
 
    foreach $arrayRef (@$arrayOfArrays) {
	my $fullName = (@$arrayRef[1]." ".@$arrayRef[2]);

	$operatorHash{$fullName}          = @$arrayRef[0];
	$self->{email_id_of}->{$fullName} = @$arrayRef[3];
    }

    $operatorHash{'<nobody>'} = ''; # if user selected someone, then changed 
                                    # their mind.

    return \%operatorHash;
}

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

    my $status = $dbh->fetch_scalar(qq[ select STATUS
                                        from   PROJECT_STATUS
                                        where  ISCURRENT   = 1
                                        and    PROJECTNAME = '$clone_name'
                                        ]);

    if( $status == 24 ){ 
        return 1;
    }
    else {
        return 0;
    }
}

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

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

    print STDERR "ERROR: $message";

    Mail::sendMail( -to      => 'bug',
                    -subject => "Lemur Error", 
                    -message => $message);

    die "";
}

#####
# EOF
#####
1;

# $Log: LemurUtils.pm,v $
# Revision 1.14  2000/11/01  17:30:19  pjm
# Hopefully the showInfo(), showError() and yesNo() subs now create
# a Dialog box which is Tk8 compliant.
#
# Revision 1.13  2000/04/14  10:21:09  pjm
# added get_job_num_for_ligation()
#
# Revision 1.12  2000/04/11  15:01:01  pjm
# added "$dialog->destroy()" code so won't use 50k at a time
#
# Revision 1.11  2000/03/30  12:48:56  pjm
# added sub get_id_person_from_email_name().
#
# Revision 1.10  2000/02/16  17:44:31  pjm
# added is_project_cancelled
#
# Revision 1.9  2000/01/26  14:44:48  pjm
# added get_team_person_role_id_role_for() and is_valid_clone_name()
#
# Revision 1.8  1999/11/22 16:49:09  pjm
# added get_user_name_from_email_name().
# Rearranged subs so all DB access ones at bottom of file.
#
# Revision 1.7  1999/11/12 17:18:00  pjm
# added isValidNumber, getVectorList, getVectorsWithEnzymes
#
# Revision 1.6  1999/07/16 11:38:19  pjm
# added subs yesNo & isGoodDate.
#
# Revision 1.5  1999/07/01 14:14:25  pjm
# did not out '$' after $Id or $Log (dohh!)
#
