package ATR::MiceSubPE;

use strict;
use warnings;

use ATR::GTx;
use Carp;

=head1 NAME

ATR::MiceSubPE - base class for some GT:P:E wrappers

=head1 DESCRIPTION

This base class provides "GeneriTrack to AniTrack translation"
functionality for sub-entities and entities.

=cut

# $Id: MiceSubPE.pm,v 1.11 2005/05/10 17:12:56 mca Exp $
our $VERSION = (qw$Revision: 1.11 $)[1];


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

=head1 CLASS METHODS

=cut

# Maybe the storing of current-session belongs here as base class functionality?
sub getSessionId { ATR::GTx->getSessionId }

# XXX: We need telling about change of userid
sub getIdRole {
    my $self = shift;
    return $self->getGTx->currentIdRole;
}


=head2 getGTx()

Initially this is a class method, but treat it as an object method
where possible so we can hit on multiple databases later without too
much pain.

Currently just grabs the L<ATR::GTx> singleton instance.
XXX: Maybe this means the single instance of our GTx belongs here?

=cut

sub getGTx {
    my $self = shift;
    return ATR::GTx->singleton;
}


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


=head2 _getName($id_name_type)

Short-cut for subclasses; fetches from C<$self-E<gt>_getSubPE> the
name of the given type, ignoring any other types present.

In list context, returns list of names looked up from ATR_NAMES table.
Expect one.

In scalar context, returns the name if there is exactly one, else
dies.

Names are set for all time, usually when the entity was made.

Errors propagate, and generated if the Shape is bad.

=cut

sub _getName {
    my ($self, $id_name_type) = @_;
    my $gtx = $self->getGTx;

    # Find relevant info...  expect one, allow any number
    my ($info_list) = $gtx->
      getInfo(-pe => $self->_getSubPE,
	      -idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
	      -reason => ATR::GTx::REASON_IDENTIFIED_BY);
    my @info = @$info_list;

    # Convert entity's ID_NAMEs into list of name strings,
    # filter out ones with wrong type (or rolled back rows)
    my @names = map {
	my $id_name = $_->getIdContent();
	my ($name, $nametype) = ATR::BioTables->getName_forId($id_name);
	(defined $nametype && $nametype == $id_name_type) ? ($name) : ();
    } @info;

    # Return names
    if (wantarray) {
	return @names;
    } elsif (@names == 1) {
	return $names[0];
    } else {
	my $pe = $self->_getSubPE;
	my $peid = $pe->getId; # XXX: No GTx method
	my $pe_descr;
	if ($pe->isa('GT::Physical::Entity')) {
	    $pe_descr = "PEid=$peid, type=".$pe->getIdEntityType;
	} else {
	    $pe_descr = "SubPEid=$peid, type=".$pe->getIdEntityContentsType;
	}
	# XXX:USRTHROW
	my $obj_type = ref($self)->debugId;
	my $name_type = ATR::BioTables->atr_name_type_dict($id_name_type)->[1] || '[unknown name type]';
	confess "Found $obj_type ($pe_descr) with no name of type $name_type" if !@names;
	confess "Found $obj_type ($pe_descr), has more than one name (@names) of type $name_type but only one was expected"
	  if @names != 1;
    }
}


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

sub getSubPeID { $_[0]->_getSubPE->getId }

=head2 setFreeRemark($remarkType, $cancelByType, $value)

ATR comment attributes: for all entity types, various subentities;
plan is to replace some with dedicated attributes and the rest with
categorised (by link to bio table) remarks.

Set a "freely categorised remark" (FCREMARK) attribute.

Old value(s) will be marked not current if $cancelByType is true.  New
attribute will not be created if $value is undef or the empty string.

=cut

sub setFreeRemark {
    my ($self, $remarkType, $cancelByType, $value) = @_;
    croak "Object method needs 3 args" unless @_ == 4;

    my $gtx = $self->getGTx;

    if ($cancelByType) {
	# invalidate old attributes (if any)
	my @old_attr = $self->_getAttr_FreeRemark($remarkType);
	foreach my $old (@old_attr) {
	    $gtx->cancelAttribute($old) if $old->getIsCurrent;
	}
    }

    $gtx->addAttribute(-pe => $self->_getSubPE,
		       -attributeType => ATR::GTx::ATT_TYPE_FCREMARK,
		       -value => $remarkType,
		       -remark => $value,
		       -reason => GTx::REASON_ATTRIBUTE,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId)
      unless !defined $value || $value eq '';

    $self->_flush;
}

sub _getAttr_FreeRemark {
    my ($self, $remarkType) = @_;
    my $gtx = $self->getGTx;

    my ($listref) = $gtx->getAttribute(-pe => $self->_getSubPE,
				       -attributeType => ATR::GTx::ATT_TYPE_FCREMARK,
				       -reason => GTx::REASON_ATTRIBUTE);

    return () unless $listref;
    return grep { $_->getValue eq $remarkType } @$listref;
}

=head2 getFreeRemark($remarkType)

In list context, returns all the remark values of the requested type
(which may be none).  Ordering is not defined.

XXX: sort by attribute date [not returned here]

In scalar context, returns one remark value or undef if there are
none.  Error if there is more than one (because you're not expecting
it).

Errors propagate up.

=cut

sub getFreeRemark {
    my ($self, $remarkType) = @_;
    croak "Object method needs 1 arg" unless @_ == 2;

    my @old_attr = $self->_getAttr_FreeRemark($remarkType);

    if (@old_attr > 1 && !wantarray) {
	confess "Multiple values found for remark type '$remarkType' of "
	  .$self->debugId;
    }

    my @value = map { $_->getRemark } @old_attr;
    return wantarray ? @value : $value[0];
}


=head2 invalidate

Currently not implemented.

Cause the object to forget its currently loaded data and re-adopt from
the database.

The re-adoption may be delayed until it is needed.  Also, listeners
such as GUI models could by this call be informed that their data is
stale.

Errors on failure...?

=cut

sub invalidate {
    my $self = shift;
    die "Invalidate method is not yet implemented"; # XXX: or rather, we can ditch our GT object but have no code to re-adopt on demand
    # this 'die' will (at least) prevent the AnimalTransfer window staying open if there is a rollback
}


# This uses eval,
# and that seems to confuse Tk::Error or Tk::catch,
# so the errors just disappear instead of being reported,
# or have an incorrect stack trace.
  #sub DESTROY {
  #    my $self = shift;
  #    warn "DESTROY: ".$self->debugId."\n\\";
  #}


1;
