package ATR::MicePE::Card;

use strict;
use warnings;

use ATR::Util;
use Checkbarcode2 (); # to generate the checksum
use base 'ATR::MicePE';

use Carp;


=head1 NAME

ATR::MicePE::Card - abstract class, common things for cards

=head1 DESCRIPTION

Shared between MatingPair and Weaning cards.

XXX: Maybe this should be a MiceSubPE?  It relates specifically to the Entire part of the card.
...there are now methods for finding subentities, too...

=cut


# $Id: Card.pm,v 1.9 2005/03/01 19:39:02 mca Exp $

#----------------------------------------------------------------------------
#
# Abstract overrides

sub _getPE { $_[0]->{_PE} }

# This flush is called by the main data method(s), nobody else needs it
sub _flush {
    my $self = shift;
# XXX: $self->_getPE->checkPattern [GTx method?] before flushes
# $self->_getPE->makePattern(-idConcreteIo => ?)
    $self->_getPE->flush;
}

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

# caller must flush; adds a new barcode without checking for existing ones
sub _addBarcode {
    my $self = shift;

    my $gtx = $self->getGTx;
    my $et = $self->idEntityType;
    my $barcode_serial = $gtx->getSequenceNumber(-entityType => $et);
    my $barcode_prefix = $gtx->getBarcodeInfo(-entityType => $et);
    $gtx->addAttribute(-pe => $self->_getPE,
		       -attributeType => GTx::ATT_TYPE_INT_ID,
		       -value => $barcode_serial,
		       -remark => $barcode_prefix, # store prefix too
		       -reason => GTx::REASON_ATTRIBUTE,
		       -idRole => $self->getIdRole,
		       -sessionId => $self->getSessionId);
}



=head2 Cheapskate delegations via get/set FreeRemark

To be replaced with relevant bio tables, once the structure settles.

=over 4

=item getLicencePIL / setLicencePIL($string)

=item getLicencePPL / setLicencePPL($string)

=item getLicence19b / setLicence19b($string)

=item getLicenceUser / setLicenceUser($string)

(Note that this is currently separate from the "responsible person"
attribute.)

=back

=cut

use constant FCREM_PIL  => '_LicPIL';
use constant FCREM_PPL  => '_LicPPL';
use constant FCREM_19b  => '_Lic19b';
use constant FCREM_USER => '_LicUser';

sub getLicencePIL   { scalar $_[0]->getFreeRemark(FCREM_PIL)           }
sub setLicencePIL   { $_[0]->setFreeRemark(FCREM_PIL, 1, $_[1]) }

sub getLicencePPL   { scalar $_[0]->getFreeRemark(FCREM_PPL)           }
sub setLicencePPL   { $_[0]->setFreeRemark(FCREM_PPL, 1, $_[1]) }

sub getLicence19b   { scalar $_[0]->getFreeRemark(FCREM_19b)           }
sub setLicence19b   { $_[0]->setFreeRemark(FCREM_19b, 1, $_[1]) }

sub getLicenceUser  { scalar $_[0]->getFreeRemark(FCREM_USER)           }
sub setLicenceUser  { $_[0]->setFreeRemark(FCREM_USER, 1, $_[1]) }


=head2 getBarcode

Return C<($barcode_prefix, $serial)> in list context, C<$serial> in
scalar context.  The barcode prefix is taken from the remark field; no
check is made to compare this for what's currently defined for the
entity type.

Errors: propagate from database, or if there is not exactly one
current barcode.

=cut

sub getBarcode {
    my $self = shift;
    my $gtx = $self->getGTx;
    my ($listref) = $gtx->getAttribute(-pe => $self->_getPE,
				       -attributeType => GTx::ATT_TYPE_INT_ID,
				       -reason => GTx::REASON_ATTRIBUTE);
    my @attr = @$listref;

    if (@attr != 1) {
	my @found = map { $_->getRemark . $_->getValue } @attr;
	local $" = ", ";
	croak "Card ".$self->debugId."should have only one barcode, but found (@found)";
    }

    return wantarray ? ($attr[0]->getRemark, $attr[0]->getValue) : $attr[0]->getValue;
}

sub getBarcodeString {
    my $self = shift;
    my ($bc_pfx, $bc_num) = @_;
    ($bc_pfx, $bc_num) = $self->getBarcode if !defined $bc_pfx;

    # Add leading zeroes require Checkbarcode2 not Checkbarcode
    # Choice of %07d is somewhat arbitrary
    $bc_num = sprintf("%07d", $bc_num);

    my $bc_str = Checkbarcode2::makeID($bc_pfx.$bc_num)
      or die "Can't make barcode from ($bc_pfx, $bc_num)";

    return $bc_str;
}


#----------------------------------------------------------------------------
#
# Generic PennedMouse handling

=head2 getPennedById($subPeId)

Return a cached L<ATR::MicePE::PennedMouse> object, found by its
sub-entity ID within this card.

Error if the ID is not found.

=cut

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

    # Get the subentity by its ID  XXX:GTx have to do this in two passes
    my ($listref) = $gtx->getSubEntity(-pe => $self->_getPE,
				       -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_PENNED);
    my ($wanted) = safegrep { shift->getId == $subPeID } @$listref;
    die "Couldn't find PA(subentId=$subPeID) in ".$self->debugId unless $wanted;

    return $self->_getPenned($wanted);
}


=head2 getAllMouseVisits()

Returns count (scalar context) or list of PennedMouse objects which
remain current on the card.

=cut

sub getAllMouseVisits {
    my $self = shift;
    my $gtx = $self->getGTx;

    my ($listref) = $gtx->getSubEntity(-pe => $self->_getPE,
				       -idEntityContentsType => ATR::GTx::ENT_CONT_TYPE_ATR_PENNED);

    my @penned = safemap { $self->_getPenned(shift) } @$listref; # loses cancelled items
    return @penned;
}


# Create PennedMouse object or take from cache
#   Scalar context: object or undef
#   List context: object or empty list
sub _getPenned {
    my ($self, $pennedSubEnt, $constructed) = @_;
    my $pennedCache = $self->{penned_by_contId} ||= {};
    my $key = $pennedSubEnt->getId;
    if (!exists $pennedCache->{$key}) {
	$pennedCache->{$key} =
	  ($constructed || ATR::MicePE::PennedMouse->construct($self, $pennedSubEnt));
    }
    my $item = $pennedCache->{$key};
    return( wantarray
	    ? (defined $item ? ($item) : ())
	    : $item );
}

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

{
    package Checkbarcode2; # XXX: see helpdesk ticket 24457; this method replacement is a quick-fix bodge
    sub validID {
	my ($s, $type) = @_;
	return "" if $s !~ /^[A-Z][A-Z][0-9]+[A-Z]$/;
	if (defined $type) {
	    #Modified to return NULL on type miss match
	    return "NULL" if $type ne substr($s, 0, 2);
	}
    
	my $ck = substr($s, length($s) - 1, 1);
	return $ck eq makeCheck(substr($s, 0, -1));
    }
}

1;
