package ATR::MicePE;

use strict;
use warnings;

use ATR::GTx;
use Carp;

use base 'ATR::MiceSubPE';

# $Id: MicePE.pm,v 1.26 2005/05/23 16:10:42 mca Exp $
our $VERSION = (qw$Revision: 1.26 $)[1];

=head1 NAME

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

=head1 DESCRIPTION

These wrappers constitute a "translation layer" between the GUI and
the GT objects and bio tables.  [Previously I had thought of them as
"database objects", just more specialised than the GT ones...  but
they hold no extra state.  They are method wrappers for translation.]

This class is specific to full entities.  Sub-entities are handled by
L<MiceSubPE.pm>, of which this is a sub-class.

 XXX: Possible need for (sub)PEid to object caching?  Would make life easier in the GUI ... but A:M:Weaning->_getPennedForAttr does this now

=head1 CLASS METHODS - GTX FLAVOURED


=head2 commitAll()

Call C<commitTransaction> for L<GT> (by use of L<GTx>) and for
L<ATR::BioTables>.

=cut

sub commitAll {
    my $self = shift;
    croak "Call as class method on base class, it commits all handles"
      if ref($self) || $self ne __PACKAGE__;

    warn "COMMIT!\n";
    $self->getGTx->commitTransaction;
    ATR::BioTables->commitTransaction;
}


=head2 rollbackAll()

Call C<rollbackTransaction> for L<GT> (by use of L<GTx>) and for
L<ATR::BioTables>.

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

=cut

sub rollbackAll {
    my $self = shift;
    my $why = shift || 'unspecified reason';
    croak "Call as class method on base class, it rolls back all handles"
      if ref($self) || $self ne __PACKAGE__;

    warn "ROLLBACK for $why!\n" unless $why eq 'testcase';
    ATR::GTx->rollbackTransaction;
    ATR::BioTables->rollbackTransaction;
}


=head2 getEntityStatusDict

Returns hash of { Statusname =E<gt> ID_STATUS} for the calling class.
Can't be done to the base class.

=cut

sub getEntityStatusDict {
    my $self = shift;
    return ATR::GTx->getStatusDict( $self->idEntityType, GTx::ENT_CONT_TYPE_ENTIRE );
}


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

=head1 CLASS METHODS - ATR FLAVOURED

Maybe a generic "find anything by string" method?  Probably best done
as a collection of the others.


=head2 _findByName($atr_name, $id_name_type)

(For use by subclasses)

Find and return one entity "identified by" the given name, or undef if
not found.  Does the ATR_NAME lookup and adoption.

XXX[GTx] generalise with getPeByStatus & getPhysicalEntity

XXX: Undefined or scary if there are ever two PEs with matching name [currently confesses]

=cut

sub _findByName {
    my ($proto, $name, $id_name_type) = @_;

    # Get name
    my $id_name = ATR::BioTables->getName_idName($name, $id_name_type);
    return undef if !defined $id_name;

    my $gtx = $proto->getGTx;
    my $PE = $gtx->getPEbyInfo( -adopt => 1,
				-entityType => $proto->idEntityType,
				-idEntityContentsType => GTx::ENT_CONT_TYPE_ENTIRE,
				-idContentType => ATR::GTx::CONT_TYPE_ATR_NAME,
				-idContent => $id_name,
				-reason => ATR::GTx::REASON_IDENTIFIED_BY );
    # scalar context: will barf on multiple match

# XXX: shape check now? how can I link this with the code checks below?
    return undef if !defined $PE;

    my $class = ref($proto) || $proto;
    return bless { _PE => $PE }, $class;
}

sub findByBarcode {
    my ($proto, $pfx, $num) = @_;

    my $gtx = $proto->getGTx;
    my $list = $gtx->getEntityTypeByBarcode($pfx, 0+$num); # XXX: could accept multi here?
    return undef if !$list;

    my ($entType, $peId, $current) = @$list;
    return undef if !$current;

    my $class = { ATR::GTx::ENT_TYPE_ATR_MOUSE => 'ATR::MicePE::Mouse',
		  ATR::GTx::ENT_TYPE_ATR_MOUSE_MATING => 'ATR::MicePE::MatingPair',
		  ATR::GTx::ENT_TYPE_ATR_MOUSE_WEANING => 'ATR::MicePE::Weaning',
		}->{$entType};
    croak "Barcode '$pfx$num' is not a known AniTrack Mouse Card" unless $class;

    return $class->findByPeId($peId);
}

sub findByPeId {
    my ($proto, $peId) = @_;
    die "Class method needs 1 arg" unless @_ == 2 && defined $peId;

    my $gtx = $proto->getGTx;
    my $PE = $gtx->getPhysicalEntity(-idPe => $peId, -entityType => $proto->idEntityType);
    return undef unless $PE;

    my $class = ref($proto) || $proto;
    return bless { _PE => $PE }, $class; # XXX: need a _newWithPE($PE) method
}

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

=head1 ABSTRACT METHOD PLACEHOLDERS

Base class methods C<confess>, need overriding.

=over 4

=item idEntityType

Class method.  Should return a L<GTx> C<ENT_TYPE_*> constant.

=item _flush

Object method.  Should check and flush whatever entities the object
holds.

=item _getPE

Object method.  Should return the main physical entity held.

=item debugId

Object method tells what we know of the object, for error messages.
Will cope with being a class method.

=item XXX: reAdopt ? ...else what if the DBHs are both rolled back and we're left holding obselete data...

=back

=cut

sub idEntityType { confess "Abstract base class entity type requested" }
sub _flush { confess "Abstract base class _flush called - nothing to do" }
sub _getPE { confess "Abstract base class _getPE called - nothing to do" }
sub debugId { carp "Superclass debugId($_[0]) called"; "debug[$_[0]]" }


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

=head1 OBJECT METHODS

=cut

# Object represents whole entity, so _getSubPE needs to be the
# 'Entity' not an attached 'entity content', for GTx to work; conflict
# because to keep the pattern sensible we should provide the "entity
# content=entire contents" object instead
sub _getSubPE { $_[0]->_getPE }
# MiceSubPE class uses this for _getName and set/getFreeRemark

sub getPeID { $_[0]->_getPE->getId } # XXX: No GTx method


1;
