package ATR::BioTables;

use strict;
use warnings;

use SqlEngine2;
use Carp;
use constant 1.04; # for multi constants, comes with Sanger 5.8.0 not 5.6.1

use ATR::Date;

=head1 NAME

ATR::BioTables - handle the AniTrack bio tables attached to GT PEs

=head1 DESCRIPTION

Wrap up L<SqlEngine2> and the calls on the bio tables.

This is a class of class methods.  There is no object to instantiate.
Well you could make one if you wanted...

B<Note> all names and other strings are B<case sensitive>.  This is
how Oracle works, it's also how mouse people work.

=head1 PUBLIC FEATURES

=cut

#----------------------------------------------------------------------------
#
# Looking after SqlEngine2

{
    # Globals are icky.  Our alternative would be to make a SqlEngine3
    # subclass which remembers what it's talking to.
# XXX: SqlEngine3 feature request: put sql_lib files in %INC for benefit of McaTestOverview.pm->test_notes_to_self
    my $se2login;
    my $se2obj;
    my $se2dbh;

=head2 ATR::BioTables-E<gt>config($bio_login)

Set the L<WrapDBI> login for bio table access. Call it once, call it
early.

The caller has the responsibility to call
C<ATR::MicePE-E<gt>rollbackAll> and C<ATR::BioTables-E<gt>endDbh> in
an C<END> block.

=cut

    sub config {
	my $class = shift;
	croak "config called more than once" if defined $se2login;
	$se2login = shift;
    }

    my $getLogin = sub {
	croak "call 'config' before using ".__PACKAGE__
	  unless defined $se2login;
	return $se2login;
    };

    sub _getSE2 {
	my $class = shift;

	if (!defined $se2obj) {
	    $se2obj = SqlEngine2->new("BOGUSDEFAULTLOGIN"); # best way to find out what gets broken
	    $se2obj->loadSqlLib([
				 'ATR/ATR_GTx',
				 'ATR/BioTables'
				]);
	}
	return $se2obj;
    }

    sub _hasDbh {
	return (defined $se2dbh);
    }

    sub _getDbh {
	return $se2dbh ||= SqlEngine2::getDbh($getLogin->());
    }

    # POD is below
    sub endDbh {
	my $self = shift;
	SqlEngine2::endDbh($se2login) if $self->_hasDbh;
	undef $se2dbh;
	undef $se2obj; # drop the sql_libs at the same time
	# so the caller's setting of verbosity takes effect
    }
}

# my $rows = ATR::BioTables->_getAll('ATR/BioTables::FooQuery', [1, 2, 3]);
#   returned rows are @$rows
sub _getAll {
    my ($self, $sqlname, $params) = @_;
    confess "Need 2 args on class method" unless @_ == 3;
    warn "_getAll called in list context, but returns an ARRAYref" if wantarray;

    return $self->_getSE2->getAll($sqlname, $params, $self->_getDbh);
}

sub _do {
    my ($self, $sqlname, $params, $quiet) = @_;
    confess "Need 3 args on class method"
      if @_ != 4
	|| ref($quiet); # not a dbh!

    return $self->_getSE2->do($sqlname, $params, $self->_getDbh, $quiet);
}

=head2 Handle wrappers

This library's user is responsible for coordinating commit/rollback
with the L<GT> or L<GTx> libraries, and calling C<endDbh> to close
down.

These are wrapped because the caller shouldn't need to fish out our
DBH and pass it on.

=over 4

=item ATR::BioTables-E<gt>beginTransaction()

=item ATR::BioTables-E<gt>rollbackTransaction()

It is safe to call this method when there is no DBH or SE2 object.

=item ATR::BioTables-E<gt>commitTransaction()

=item ATR::BioTables-E<gt>endDbh()

It is safe to call this method when there is no DBH or SE2 object.

=back

=cut

sub beginTransaction    { my $self = shift; $self->_getSE2->beginTransaction   ( $self->_getDbh ); }
sub commitTransaction   { my $self = shift; $self->_getSE2->commitTransaction  ( $self->_getDbh ); }
sub rollbackTransaction {
    my $self = shift;
    if ($self->_hasDbh) {
	$self->_getSE2->rollbackTransaction( $self->_getDbh );
    }
}


#----------------------------------------------------------------------------
#
# CONTENT_STATUS_DICT
# Sub-entity status values stored in bio table, because GT{x,} don't support them yet

use constant ({ SUBSTATUS_MLG_CRE => 1, # MLG is "mouse litter group"
		SUBSTATUS_MLG_DISC => 2,
		SUBSTATUS_MLG_WEAN => 3,
		SUBSTATUS_MLG_CHEW => 4,
		SUBSTATUS_MLG_CANC => 5,
	      });

{
    my %atr_content_status_dict;

    my $popdict = sub {
	my $self = shift;
	my $rows = $self->_getAll('ATR/BioTables::slurpContentStatusDict', []);
	foreach my $R (@$rows) {
	    my ($id, $descr, $meaning, $code, $entityType, $entityContentsType) = @$R;
	    $atr_content_status_dict{$id} = $atr_content_status_dict{$code} = $R;
	}
    };

    # Look up list by code (text) or id (number)
    # Returns [ id, description, meaning, code, entityType, entityContentsType ]
    # Dies if you ask for something that doesn't exist
    sub content_status_dict {
	my ($self, $type) = @_;

	$popdict->($self) unless scalar keys %atr_content_status_dict;
	if (!defined $type) {
	    return keys %atr_content_status_dict;
	} elsif ($atr_content_status_dict{$type}) {
	    return @{ $atr_content_status_dict{$type} };
	} else {
	    die "CONTENT_STATUS_DICT lookup for '$type' failed, item not found";
	}
    }
} # XXX: this block almost redundant with the %atr_name_type_dict one


#----------------------------------------------------------------------------
#
# ATR_NAME handling

use constant ({ NAMETYPE_MCOLONY => 1,
		NAMETYPE_MMATING => 2,
		NAMETYPE_MLITTER => 3,
		NAMETYPE_MOUSE   => 4,
	      });

{
    my %atr_name_type_dict;

    my $popdict = sub {
	my $self = shift;
	my $rows = $self->_getAll('ATR/BioTables::slurpAtrNameTypeDict', []);
	foreach my $R (@$rows) {
	    my ($id, $code) = ($R->[0], $R->[2]);
	    $atr_name_type_dict{$id} = $atr_name_type_dict{$code} = $R;
	}
    };

    # Look up list by code (text) or id (number)
    # Returns [ id_name_type, description, code, name_regexp ]
    # Dies if you ask for something that doesn't exist
    sub atr_name_type_dict {
	my ($self, $type) = @_;

	$popdict->($self) unless scalar keys %atr_name_type_dict;
	if (!defined $type) {
	    return keys %atr_name_type_dict;
	} elsif ($atr_name_type_dict{$type}) {
	    my @ret = @{ $atr_name_type_dict{$type} };
	    return \@ret; # avoid returning ref to our copy
	} else {
	    die "ATR_NAME_TYPE_DICT lookup for '$type' failed, item not found";
	}
    }

    sub atr_name_type_dict_size { return (scalar keys %atr_name_type_dict) / 2 }
}


=head2 ATR::BioTables-E<gt>getName_idName($name, $id_name_type)

C<$id_name_type> will be a constant of the form
ATR::BioTables::NAMETYPE_*

Returns the ID_NAME value if C<$name> is a valid name of that type,
else returns C<undef> if the name does not exist.

Errors propagate.

=cut

sub getName_idName {
    my ($self, $name, $id_name_type) = @_;
    my $rows = $self->_getAll('ATR/BioTables::get_id4typed_AtrName', [ $name, $id_name_type ]);
    # unique index ensures @$rows == 0 or 1
    return undef unless @$rows;
    return $rows->[0]->[0];
}


=head2 ATR::BioTables-E<gt>getName_forId($id)

C<$id> is a value previously returned by C<newName_idName>.

In list context, returns the ($name, $id_name_type) or empty list if
C<$id> was not allocated.

In scalar context, returns $name or undef if C<$id> was not allocated.

C<$id_name_type> will be a value represented by a constant of the form
ATR::BioTables::NAMETYPE_*; C<$name> will be a string.

Errors propagate.

=cut

sub getName_forId {
    my ($self, $id) = @_;
    my $rows = $self->_getAll('ATR/BioTables::get_AtrName4id', [ $id ]);
    return () unless @$rows;
    return wantarray ? @{ $rows->[0] } : $rows->[0]->[0];
}


=head2 ATR::BioTables-E<gt>newName_idName($name, $id_name_type)

Parameters as for C<getName_idName>.

Returns the ID_NAME value if C<$name> was successfully created (did
not already exist as a name of that type), else returns C<undef> if
the name did exist.

Errors propagate; this may involve re-throwing.

XXX: This insert could wait indefinitely for another session to commit/rollback!

=cut

sub newName_idName {
    my ($self, $name, $id_name_type) = @_;
    my $added = eval {
	$self->_do('ATR/BioTables::add_AtrName', [ $name, $id_name_type ], 1);
	# error is likely to be unique index violation
	1;
    };
    my $prob = $@;
    my $id = $self->getName_idName($name, $id_name_type); # or get the .currval ?
# XXX: Check $prob .. using other session's committed name?
    if (defined $id) {
	return $id if $added;
	return undef; # did exist
    } else {
	die $prob;
    }
}


=head2 ATR::BioTables-E<gt>getName_NextSerial($id_name_type, $prefix, \@skipNames)

Return a name which (unless somebody gets there before you) could be
created with C<newName_idName($new_name, $id_name_type)> .  It will be
of the form C<$prefix$serial> , where $serial is a number which we
generate by counting and trying. XXX: This could be slow in some circumstances.

This is messy, but the alternative seems to be an Oracle sequence per
colony; or an extra bio table to do the same job; or just having
colony+serial number on the ECIA, skip the name.

There are probably many good ways to do this.  Instead, we start from
just below the current count of names matching the prefix in this
nametype and skip upwards +=1'ly until we find something not
allocated.  Pathological if we already have C<${prefix}1000> to
C<${prefix}2000> allocated, but that's not too likely.

In addition, any item in C<@skipNames> will not be considered
available.

=cut

sub getName_NextSerial {
    my ($self, $id_name_type, $prefix, $skipNames) = @_;
    my %skip;
    @skip{@$skipNames} = () if defined $skipNames;

    my $matches = $self->_getAll('ATR/BioTables::count_AtrName4prefix', [ "$prefix%", $id_name_type ])
      ->[0]->[0];

    my $try = $matches - 5;
    $try = 1 if $try <= 0;
    while ( defined $self->getName_idName($prefix.$try, $id_name_type) ||
	    exists $skip{$prefix.$try}
	  )
    {
	$try += 1;
    }

    return $prefix.$try;
}


#----------------------------------------------------------------------------
#
# GENOTYPE handling


=head2 ATR::BioTables-E<gt>getGenotypeId( -raw =E<gt> $raw_name )

B<nb. call style likely to change if/when genotypes get their own
class.>

In scalar context, returns a valid ID_GENOTYPE value (the lowest) for
the given name, either the existing one or a newly created one.

In a list context, works the same but may return several ID_GENOTYPE
values which represent equivalent genotypes.

B<Multiple equivalent records can't be avoided> without risking a wait
period while one client waits for another to commit a newly created
genotype.  Argh.

Errors propagate.

=cut

sub getGenotypeId {
    my ($self, %data) = @_;
    croak "Class method takes 2 args" unless @_ == 3;
    croak "'raw' field is required" unless defined $data{-raw};
    my @info = $self->getGenotypeInfo(-raw => $data{-raw});
    if (!@info) {
	$self->_addGenotypeId(%data);
	@info = $self->getGenotypeInfo(-raw => $data{-raw});
	confess "Failed to find newly added GENOTYPE(raw_name=$data{-raw})" unless @info;
    }
    my @results = map { $_->{id} } @info;
    if (wantarray) {
	return @results;
    } else {
	return undef if !@results;
	return $results[0];
    }
}

sub _addGenotypeId {
    my ($self, %data) = @_;
    confess "private method takes key/value" unless @_ == 3 && defined $data{-raw};
    $self->_do('ATR/BioTables::add_genotype', [ $data{-raw} ], 0);
}


=head2 ATR::BioTables-E<gt>getGenotypeInfo( -E<lt>querykeyE<gt> =E<gt> $val )

Get info about an existing genotype.  Parameters must be B<one>
key/value pair, valid keys are

 -id
 -raw

Look up genotype records and return the first item (in scalar context)
or all items (in list context), as a hashref containing

 {
  id => $id_genotype,
  raw => $raw_name,
 }

If there are no matches, returns undef (scalar context) or empty list.

Errors propagate.

=cut

sub getGenotypeInfo {
    my ($self, $key, $val) = @_;
    croak "Class method takes 2 args" unless @_ == 3;
    my $query = { -id  => 'ATR/BioTables::get_genotype4id',
		  -raw => 'ATR/BioTables::get_genotypes4raw',
		}->{$key};
    croak "Unknown key type '$key'" unless $query;
    my $rows = $self->_getAll($query, [ $val ]);
    my @results = map {{ id => $_->[0], raw => $_->[1] }} @$rows;
    if (wantarray) {
	return @results;
    } else {
	return undef if !@results;
	return $results[0];
    }
}

# Semi-private method used by ATR::BioTablesTest to simulate a
# successful race by two dbh sessions
sub _t_dupGenotype {
    my ($self, %arg) = @_;
    $self->_addGenotypeId(%arg);
}


#----------------------------------------------------------------------------
#
# DATERANGE

sub newDateRange_Id {
    my ($self, $start, $end) = @_;

    my $want = 'ATR::Date';
    croak "Need a start date, none was given" if !defined $start;
    if (!UNIVERSAL::isa($start, $want)) {
	croak "Bad start date '$start', expected a $want";
    }
    if (defined $end && !UNIVERSAL::isa($end, $want)) {
	croak "Bad end date '$end', expected a $want";
    }
    if (defined $end && $start->cmp($end) >= 0) {
	# "end > start" just seems like a reasonable rule...
	croak "End is not after start for new DATERANGE";
    }

    $self->_do('ATR/BioTables::add_DateRange',
	       [ $start->getGT, (defined $end ? $end->getGT : undef) ], 0);
    my $id = $self->_getAll('ATR/BioTables::get_DateRange_lastId', [])->[0]->[0];

    return $id;
}

sub getDateRangeById {
    my ($self, $id) = @_;
    my $rows = $self->_getAll('ATR/BioTables::get_DateRange4id', [ $id ]);
    croak "Invalid DATERANGE id=$id\n" unless @$rows == 1;
    my ($gtStart, $gtEnd) = @{ $rows->[0] };

    return map { defined $_ ? ATR::Date->newGT($_) : undef } ($gtStart, $gtEnd);
}

sub setDateRange_end { # XXX:LOCK will wait for a different session to commit or rollback.
    my ($self, $id, $end) = @_;

    my ($start) = $self->getDateRangeById($id);
    # "end > start" just seems like a reasonable rule...
    croak "End is not after start for update of DATERANGE id=$id" if $start->cmp($end) >= 0;

    my $rows = $self->_do('ATR/BioTables::set_DateRange_end4id', [$end->getGT, $id], 0);
    return () if $rows > 0;
    croak "Cannot update DATERANGE id=$id with end='".$end->getGT."'";
}

1;
