package ATR::GTx;

use base 'GTx';
use strict;
use warnings;
use Carp;
use ATR::Util;

# More entity types
use constant ENT_TYPE_ATR_MOUSE => 25;
use constant   STATUS_MOUSE_ALIVE	=> 32; # see ATR::MicePE::MouseTest->test_status_constants
use constant   STATUS_MOUSE_DEAD	=> 33;
use constant   STATUS_MOUSE_CREATED	=> 34;
use constant   STATUS_MOUSE_CANCELLED	=> 43;
use constant   STATUS_MOUSE_LOST	=> 44;
use constant ENT_TYPE_ATR_MOUSE_MATING => 26;
use constant   STATUS_MOUSEPAIR_CREATED		=> 35;
use constant   STATUS_MOUSEPAIR_CANCELLED	=> 36;
use constant   STATUS_MOUSEPAIR_SETUP		=> 46;
use constant   STATUS_MOUSEPAIR_DISSOLVED	=> 47;
use constant ENT_TYPE_ATR_MOUSE_WEANING => 27;
use constant   STATUS_MOUSEWEAN_CREATED		=> 37;
use constant   STATUS_MOUSEWEAN_CANCELLED	=> 38;
use constant   STATUS_MOUSEWEAN_SETUP		=> 48;
use constant   STATUS_MOUSEWEAN_EMPTY		=> 49;

use constant ENT_CONT_TYPE_ATR_MATING	=> 4;
use constant ENT_CONT_TYPE_ATR_LITTER   => 5;
use constant ENT_CONT_TYPE_ATR_PENNED	=> 7;

# Role names
# XXX: ACL would be based on a combination of where the program is run (lab or office) and what the operation is?
use constant ROLE_GENERAL => "ANITRACK";

use constant REASON_IDENTIFIED_BY	=> 15;
use constant REASON_DERIVED_FROM	=> 16;

use constant ATT_TYPE_ATR_MOUSE		=> 23; #	Anitrack Mouse entity	NUMBER(38)		11
use constant ATT_TYPE_FCREMARK		=> 24; #	Freely categorised remark	VARCHAR2(240)
use constant ATT_TYPE_RESP_IDROLE	=> 25; #	Responsible person	NUMBER(38)		17
use constant ATT_TYPE_GRP_SIZE		=> 26; #	Group size		NUMBER(38)

use constant ATT_TYPE_GENOTYPE		=> 28; #	Genotype		NUMBER(38)		24
use constant ATT_TYPE_COLONY		=> 29; #	Member of colony	NUMBER(38)		25
use constant ATT_TYPE_SUBENT_STATUS	=> 30; #	Subentity status	NUMBER(38)		26
use constant ATT_TYPE_PENNED_SINCE	=> 33; #	Penned since		NUMBER(38)		30
use constant ATT_TYPE_PENNED_DURING	=> 34; #	Penned since		NUMBER(38)		30
use constant ATT_TYPE_DOB		=> 35; #	Penned since		NUMBER(38)		30
use constant ATT_TYPE_DOD		=> 36; #	Penned since		NUMBER(38)		30
use constant ATT_TYPE_ATR_WEANING	=> 38; #	Anitrack weaning card	NUMBER(38)		11
  # last column refers to CONT_TYPE_* ...
use constant CONT_TYPE_GENOTYPE		=> 24;
use constant CONT_TYPE_COLONY		=> 25;
use constant CONT_TYPE_CONTENT_STATUS	=> 26;
use constant CONT_TYPE_ATR_NAME		=> 27;

# declare these as constants so that ... we get compiletime checking of entity types?
# ...therefore reading these live from the database requires full wrapdbi configuration before compilation completes
# ...if we're not doing this, then a tied hash lookup with throwing could be neater


# $Id: GTx.pm,v 1.28 2005/05/10 17:12:57 mca Exp $
our $VERSION = qw$Revision: 1.28 $[1];

=head1 NAME

ATR::GTx - AniTrack extension of GTx

=head1 SYNOPSIS

 ATR::GTx->config(-login => 'DBIname');
 {
   my $gtx = ATR::GTx->singleton;
   $gtx->do_stuff();
 }
 {
   my $gtx = ATR::GTx->singleton; # returns the same object
 }

=head1 DESCRIPTION

GTx appears to be a singleton class.  This subclass enforces that,
then adds some extra features for AniTrack.

=head2 Caveats

Class uses file-scoped globals - beware package vs. class vs. file
if subclassing!

=head1 MODIFIED FUNCTIONALITY



=head2 Instantiation semantics

Fancy name for replacing

  my $global_gtx = GTx->new( ... );

with one call to

  ATR::GTx->config( ... );

and then use of C<ATR::GTx-E<gt>singleton> at whichever point it's
needed.  The global variable moves into its own area and you can't
confuse L<GT::Physical::Entity> and friends by configuring them twice
with different logins.

=cut

my $instance;
my @new_args;

sub new {
    my $self = shift;
    croak "$self is a singleton class, do not construct it";
}

sub config {
    my $self = shift;
    croak "Class $self has been configured already" if scalar @new_args;
    croak "Need -key => \$value pairs" unless @_ % 2 == 0;
    @new_args = @_;
}

sub singleton {
    my $self = shift;
    my $class = ref($self) || $self;
    croak "Call config() first" unless scalar @new_args;
    if (!defined $instance) {
	$instance = $self->SUPER::new(@new_args);
	bless $instance, $class;
    }
    return $instance;
}


=head2 rollbackTransaction()

Now a class or object method.

Do a rollback as for C<$gtx-E<gt>rollbackTransaction> if we have a
handle.

Won't attempt to create one if there isn't one already - but this
assumes you don't make a L<GTx> object when we're not looking.

=cut

sub rollbackTransaction {
    my $self = shift;
    if (defined $instance) {
	$self->singleton->SUPER::rollbackTransaction;
    }
}


=head2 getSessionId()

This value is now cached in the singleton, since you would generally
only need the one.

As a class method, calls itself on the singleton (convenient
shortcut).

TODO: Clear cached sessionId if we change the current user

=cut

sub getSessionId {
    my $self = shift;
    $self = $self->singleton unless ref($self);

    return $self->{__PACKAGE__."/sessionId"} ||= $self->SUPER::getSessionId;
}


=head2 createPhysicalEntity(-entityType =E<gt> $et)

Works with as class method on singleton.

Other arguments are taken from C<getSessionId()>, and data supplied to
C<setUser()>, C<setRole()> and C<setTeam()> below.

=cut

sub createPhysicalEntity {
    my $self = shift;
    $self = $self->singleton unless ref($self);

    my %args = @_;

    my $et = delete $args{-entityType} || croak "Need -entityType";
    my @left = keys %args;
    croak "Unknown args (@left)" if @left;

    return $self->SUPER::createPhysicalEntity( -entityType => $et,
					       -sessionId => $self->getSessionId,
					       -userId => $self->currentUser->getIdPerson,
					       -roleType => $self->currentRole,
					       -team => $self->currentTeam );
}


=head2 addAttribute( %args )

Implement additional argument pairs

 -remark =E<gt> $remark
 -date =E<gt> $gtDate  B<INVALID: no longer supported>

by poking the return value on its way past to our caller.

-date did set both initDate and endDate, but this turned out to be a
misguided thing to want to do so now you get an error instead.

=cut

sub addAttribute {
    my ($self, %args) = @_;

    my %do_set;
    my %set_value;
    foreach my $key (qw(-remark -date)) {
	$do_set{$key} = exists $args{$key};
	$set_value{$key} = delete $args{$key}
    }
    croak "addAttribute(-date) option no longer supported" if $do_set{-date};

    my $new_attrib = $self->SUPER::addAttribute(%args);

    $new_attrib->setRemark($set_value{-remark}) if $do_set{-remark};

    return $new_attrib;
}


=head2 getBarcodeInfo(-entityType =E<gt> $peid)

Get the sequence name and barcode prefix to use for a given entity
type.

Returns C<($barcode_prefix, $sequence_name)> in list context,
C<$barcode_prefix> in scalar context.

Errors if the entity type does not exist.

XXX:GTx Code elimination if used from getSequenceNumber

=cut

sub getBarcodeInfo
{
    my $self = shift;
    my %args = @_;

    my $eType = delete $args{-entityType};
    croak "-entityType not specified" unless $eType;

    # which sequence should we be using for this entity type?
    my $rows = $self->_atr_getAll('ATR/ATR_GTx::getSequence', [$eType]);
    # returns 0 or 1 rows (primary key)

    croak "Invalid PE type $eType" unless @$rows;
    my ($sequence, $bc_pfx) = @{ $rows->[0] };

    return wantarray ? ($bc_pfx, $sequence) : $bc_pfx;
}


#----------------------------------------------------------------------------

=head1 EXTRA FUNCTIONALITY


=head2 Persistent user info

=over 4

=item $self-E<gt>setTeam($team)

=item $team = $self-E<gt>currentTeam

=item $self-E<gt>setUser(-idPerson =E<gt> 1234)

Accepts any parameters that C<getUser> can deal with.

=item $user_object = $self-E<gt>currentUser

=item $self-E<gt>setRoleType($roletypename)

=item $roletypename = $self-E<gt>currentRole

=item $id_role = $gtx-E<gt>currentIdRole

=back

When setting the role or team, you need to ensure that the combination
is valid before you do anything with a physical entity.

Names are 'currentFoo' to avoid confusion with C<getUser> and friends,
and to suggest the storage of state instead of a lookup.

XXX: How does this interact with changes not yet flushed?  PEs adopted but not yet modified?

=cut

sub setUser {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    my $key = __PACKAGE__."/User";
    $self->{$key} = $self->getUser(@_);
    croak "Unknown user (@_)" unless $self->{$key};
}

sub currentUser {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    $self->{__PACKAGE__."/User" };
}

sub setTeam {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    $self->{__PACKAGE__."/Team"} = shift;
}

sub currentTeam {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    $self->{__PACKAGE__."/Team" };
}

sub setRole {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    $self->{__PACKAGE__."/Role"} = shift;
}

sub currentRole {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    $self->{__PACKAGE__."/Role" };
}

sub currentIdRole { # XXX: This needs caching - currently looks up with SQL per call
    my $self = shift;
    return $self->getIdRole(-userId   => $self->currentUser->getIdPerson,
			    -roleType => $self->currentRole,
			    -team     => $self->currentTeam);
}


=head2 getUserByLogin($unix_user)

Look up the current id_person for the given username, then return the
GTx getUser object for that.  Returns undef if not found.

=cut

sub getUserByLogin {
    my ($self, $unixlogin) = @_;
    $self = $self->singleton unless ref($self);
    my $rows = $self->_atr_getAll('ATR/ATR_GTx::get_Person4Login', [$unixlogin]);
    return undef unless @$rows;
    if (@$rows > 1) {
	# scary, but not impossible
	die "Multiple current id_person records found for email=$unixlogin, cannot continue";
    }
    my $id_person = $rows->[0]->[0];
    return $self->getUser(-idPerson => $id_person);
}


=head2 getPEbyInfo( %args )

Returns adopted entity(ies) or their ID_ENTITY, according to the
C<-adopt> arg.

In scalar context, returns the item, or undef if none, or dies if more
than one.  (i.e. We will not be held responsible for your failure to
ensure only one result.)

In list context, returns all items in no particular order.

Args are C<-key =E<gt> $value> pairs,

=over 4

=item -adopt

Must be 0 (default) or 1.

Returns ID_ENTITY valu(es) or adopted PE(s) respectively.

=item -entityType

Could be optional, but a really good idea.  Currently required.

=item -idEntityContentsType

The subentity type.  Could be optional, but probably good for speed.
Currently required.

=item -idContentType

=item -idContent

=item -reason

Info type, value and reason.  Required.  Parameters as featured on
C<GTx::addInfo>.

=back

SQL and adoption errors propagate.

=cut

sub getPEbyInfo {
    my ($self, %args) = @_;
    $self = $self->singleton unless ref($self);

    my @req = qw(-reason -idContent -idContentType -entityType -idEntityContentsType);
    croak "Need args of type (@req)" if grep {!defined $_} @args{@req};
    my ($reason, $idContent, $idContentType, $entityType, $idEntityContentsType) = delete @args{@req};
    my $adopt = delete $args{-adopt} || 0;

    my @unk = keys %args;
    croak "Unknown args (@unk)" if @unk;

    my $rows = $self->_atr_getAll('ATR/ATR_GTx::get_PeId4InfoContentWithTypes',
				  [
				   $entityType,
				   $idEntityContentsType,
				   $reason,
				   $idContentType,
				   $idContent
				  ]);
    my @peIdList = map { $_->[0] } @$rows;

    # Have results: return in various forms
    return () if !@peIdList;

    if (!wantarray && @peIdList > 1) {
	confess "Multiple PEs found (@peIdList) but caller expected only one"; # XXX: Typed confession? [argh, lots of these]
    }

    @peIdList = ($peIdList[0]) if !wantarray; # avoid adopting unwanted objects

    my @result;
    if ($adopt) {
	@result = map {
	    $self->getPhysicalEntity(-idPe => $_, -entityType => $entityType)
	} @peIdList;
    } else {
	@result = @peIdList;
    }

    return wantarray ? @result : $result[0];
}

# see also ATR::BioTables->_getAll
sub _atr_getAll {
    my ($self, $sqlname, $params) = @_;
    confess "Need 2 args on object method" unless @_ == 3;

    return $self->{se}->getAll($sqlname, $params, $self->{dbh});
}

# Generates and returns { Statusname => ID_STATUS } list for type
# See also: GTx->_getStatusName and _getStatusId
sub getStatusDict {
    my ($self, $entityType, $subEntityType) = @_;
    $self = $self->singleton unless ref($self);

    # There are vague plans for a GT subentity status table, but
    # currently only AniTrack has one
    croak "Sub-entity type $subEntityType not yet supported"
      unless $subEntityType == GTx::ENT_CONT_TYPE_ENTIRE;

    my $rows = $self->_atr_getAll('ATR/ATR_GTx::get_StatusDict4entityType', [ $entityType ]);
    my %dict;

    foreach my $r (@$rows) {
	my ($id, $descr, $meaning) = @$r;
	$dict{$descr} = $id;
    }

    return \%dict;
}


=head2 cancelAttribute(@attributes)

Cancel one or more attributes.  Sets isCurrent = 0 and endDate = now.
Caller should flush.

=cut

sub cancelAttribute {
    my ($self, @attr) = @_;
    $self = $self->singleton unless ref($self);

    my $now = $self->makeDate;
    foreach my $a (@attr) {
	next unless $a->getIsCurrent;
	$a->setIsCurrent(0);
	$a->setEndDate($now);
    }
}


=head2 getEntityTypeByBarcode($barcode_prefix, $intId)

Look up the given barcode.  Get the entity type(s) that fit the
prefix.  Look up ATT_TYPE_INT_ID attributes for these entityTypes and
with matching C<$intId>.

Matches only attributes which point to the info of the physical
entity: ignores attributes merely pointed to by third party entities'
info.

In array context, returns (maybe zero element) array of lists

 ( [ $entityType, $peId, $attribIsCurrent ], ... )

giving all attributes which match or used to match, in no particular
order.

In scalar context, returns one such list or C<undef> if there were no
matches.  If there were multiple matches, even non-current ones, then
an error is generated.

=cut

sub getEntityTypeByBarcode {
    my ($self, $bc_pfx, $intId) = @_;

    my $rows = $self->_atr_getAll('ATR/ATR_GTx::get_EntityInfo4Barcode', [ $bc_pfx, $intId ]);
    my @values = map {
	my ($idEntity, $entityType, $contentType, $isCurrent) = @$_;
	[ $entityType, $idEntity, $isCurrent ];
    } @$rows;

    if (@values > 1 && !wantarray) {
	confess "Multiple items found with this barcode, but only one was expected";
    }

    return wantarray ? @values : $values[0];
}


=head2 listEntitiesWithType($idEntityType)

Return list of all physical entities in the database with the requested type.

Yes, that could be a really big list.

=cut

sub listEntitiesWithType {
    my ($self, $idEntityType) = @_;
    $self = $self->singleton unless ref($self);
    my $rows = $self->_atr_getAll('ATR/ATR_GTx::get_Entities4Type', [ $idEntityType ]);
    return map { $_->[0] } @$rows;
}


=head2 listEntitiesWith(%opts)

Returns list of [PhysicalEntityID, SubEntityID] in the database with
an info or info+attribute matching the fields.

Currently this is rather specific to finding AniTrack cards with
"penned animal" or "mating group" sub-entities which "contain" the
given mouse:

 -peType    => id_entity_type
 -subPeType => defaults to GTx::ENT_CONT_TYPE_ENTIRE
 -infoReason => defaults to GTx::REASON_ATTRIBUTE
 -infoType   => defaults to GTx::CONT_TYPE_ATTRIBUTE,
 -attributeType => a GTx::ATT_TYPE_* value,
                   or undef (default) if we look for Info
 -value => required value to compare
             string equality (with attribute)
             numeric equality as foreign key (with info)

An attribute must be current in order to be eligible, but entity
status is not checked.

=cut

sub listEntitiesWith {
    my $self = shift;
    $self = $self->singleton unless ref($self);

    my %arg = make_args(\@_,
			[
			 -peType => undef,
			 -subPeType => GTx::ENT_CONT_TYPE_ENTIRE,
			 -infoReason => GTx::REASON_ATTRIBUTE,
			 -infoType => GTx::CONT_TYPE_ATTRIBUTE,
			 -attributeType => undef,
			 -value => undef,
			]);
    croak "Need a -value parameter but none was given" unless defined $arg{-value};

    my $rows;
    if (defined $arg{-attributeType}) {
	$rows = $self->_atr_getAll('ATR/ATR_GTx::get_EntitiesWithAttr',
				   [ $arg{-peType},
				     $arg{-subPeType},
				     $arg{-infoType},
				     $arg{-infoReason},
				     $arg{-attributeType},
				     $arg{-value}, # attribute.value
				   ]);
    } else {
	$rows = $self->_atr_getAll('ATR/ATR_GTx::get_EntitiesWithInfo',
				   [ $arg{-peType},
				     $arg{-subPeType},
				     $arg{-infoType},
				     $arg{-infoReason},
				     $arg{-value}, # info.id_content
				   ]);
    }

    return @$rows;
}


# Return hash elements with (dbuser => ..., dbname => ...)
sub getDatabaseInfo {
    my $self = shift;
    $self = $self->singleton unless ref($self);
    my $rows = $self->_atr_getAll('ATR/ATR_GTx::get_DatabaseInfo', []);
    my %info;
    my @heads = qw(dbuser dbname);
    for (my $i=0; $i<@heads; $i++) {
	$info{$heads[$i]} = $rows->[0]->[$i];
    }
    return %info;
}


#----------------------------------------------------------------------------

package GTx;

=head1 CODE OVERRIDES

Replacement subroutines, for non-method calls.

=head2 _getProgram

Use $0 (is there a good reason to involve C<caller()>?).  Ensure the
resulting name fits in varchar2(30).

[See mail from mca to js10,ja1 2004-10-28] XXX: Replies not taken into account

=cut

{
    no warnings;
    sub _getProgram {
	my $program = $0;
	$program =~ s:^\./::;

	# "wibblefoobar" to "...foobar" to fit in varchar2(30)
	substr($program, 0, -27) = "..." if length($program) > 30;

	return $program;
    }
}

1;
