package ATR::BioTablesTest;

use strict;
use warnings;
use base qw(ATR::DatabaseTestCase);

use ATR::Date;
use ATR::BioTables;

use constant MOUSENAME_never_inserted  => "booflinger the wicked";
use constant MOUSENAME_never_committed => "Donald";
use constant MOUSE_IDNAME_never_inserted => 7;
# (used elsewhere too)


#----------------------------------------------------------------------------
#
# Sub-entity status constants

sub test_content_status_constants { # XXX: this is at least the third dict comparison test
    my $self = shift;

    my %constant_map =
      ( MLG_CRE  => ATR::BioTables::SUBSTATUS_MLG_CRE,
	MLG_DISC => ATR::BioTables::SUBSTATUS_MLG_DISC,
	MLG_WEAN => ATR::BioTables::SUBSTATUS_MLG_WEAN,
	MLG_CHEW => ATR::BioTables::SUBSTATUS_MLG_CHEW,
	MLG_CANC => ATR::BioTables::SUBSTATUS_MLG_CANC,
      );

    my %map_actual;
    foreach my $id_dict (grep /^\d+$/, ATR::BioTables->content_status_dict()) {
	my @fields = ATR::BioTables->content_status_dict($id_dict); # XXX: incomplete, check backwards
	my ($id, $code) = ($fields[0], $fields[3]);
	$map_actual{$code} = $id;
    }
    $self->assert_deep_equals( \%constant_map, \%map_actual );
}


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

# XXX: Test name length; non-ASCII characters? sql funky quotes etc.

sub test_getName_fail {
    my $self = shift;

    # Check a name has no ID
    my $id = ATR::BioTables->getName_idName(MOUSENAME_never_inserted,
					    ATR::BioTables::NAMETYPE_MOUSE);
    $self->assert_null($id);

    # Check that errors propagate
    $self->assert_dies
      (qr/ORA-01722: invalid number/i,
       # fail because "Number" is not numeric
       sub { ATR::BioTables->getName_idName("Foo", "Number") },
       sub { ATR::BioTables->getName_forId("Number") },
      );

    # Check an ID has no name
    my @forId = ATR::BioTables->getName_forId(MOUSE_IDNAME_never_inserted);
    $self->assert_str_equals(0, scalar @forId);
}


sub test_newName_rollback {
    my $self = shift;

    my @args = (MOUSENAME_never_committed, ATR::BioTables::NAMETYPE_MOUSE);

    my $id = ATR::BioTables->newName_idName(@args);
    $self->{annotate} = { id => \$id };
    $self->assert_is_idnum($id);

    # Get it: it's in our session but not committed
    my $check = ATR::BioTables->getName_idName(@args);
    $self->assert_str_equals($id, $check);

    # Try to make it again (expect fail on unique index)
    $check = ATR::BioTables->newName_idName(@args);
    $self->assert_null($check);
    # re-check the get
    $check = ATR::BioTables->getName_idName(@args);
    $self->assert_str_equals($id, $check);

    # Check the lookup by ID
    my $get_name = ATR::BioTables->getName_forId($id);
    my @get_name = ATR::BioTables->getName_forId($id);
    $self->assert_str_equals(MOUSENAME_never_committed, $get_name);
    $self->assert_str_equals(MOUSENAME_never_committed, $get_name[0]);
    $self->assert_str_equals(ATR::BioTables::NAMETYPE_MOUSE, $get_name[1]);
    $self->assert_str_equals(2, scalar @get_name);

    # Now rollback and check it's gone
    ATR::BioTables->rollbackTransaction;
    $check = ATR::BioTables->getName_idName(@args);
    $self->assert_null($check);
}

# Check that errors are still returned if the addition fails for
# reason other than key violation
sub test_newName_fail {
    my $self = shift;

    $self->assert_dies
      (qr/ORA-01400: cannot insert NULL into/i,
       sub {
	   # fails because 'undef' will be passed as SQL param; we're
	   # abusing a lurid corner case
	   ATR::BioTables->newName_idName(undef, ATR::BioTables::NAMETYPE_MOUSE);
       },
       sub {
	   ATR::BioTables->newName_idName("",    ATR::BioTables::NAMETYPE_MOUSE);
       });
}


sub test_name_constants {
    my $self = shift;

    my %constant_map =
      ( MCOLONY => ATR::BioTables::NAMETYPE_MCOLONY,
	MMATING => ATR::BioTables::NAMETYPE_MMATING,
	MLITTER => ATR::BioTables::NAMETYPE_MLITTER,
	MOUSE   => ATR::BioTables::NAMETYPE_MOUSE,
      );

    # Expected values as above
    my @names = keys %constant_map;
    my @const2id = @constant_map{ @names };

    # Try to break it by the reference that comes back
    ATR::BioTables->atr_name_type_dict('MOUSE')->[0] = "wibble";

    # Actual values
    my @names2id = map { ATR::BioTables->atr_name_type_dict($_)->[0] } @names;
    my @id2names = map { ATR::BioTables->atr_name_type_dict($_)->[2] } @const2id;
    my $count = ATR::BioTables->atr_name_type_dict_size;

    $self->{annotate}->{coded} = [ sort (@const2id, @names) ];
    $self->{annotate}->{in_db} = [ sort ATR::BioTables->atr_name_type_dict ];

    # Check the ones we have are the right values (match the CODE column)
    $self->assert_deep_equals( \@const2id, \@names2id );
    $self->assert_deep_equals( \@names, \@id2names );

    # Check we have them all
    $self->assert_str_equals(scalar @names, $count);
}


sub test_name_NextSerial {
    my $self = shift;

    # Set up two prefixes to play with, second is first plus 'xx'
    my ($nametype, $pfx) = (ATR::BioTables::NAMETYPE_MMATING, "EZPZ");
    my $pfx_X = $pfx."xx";

    # Shortcuts
    my @ids;
    $self->{annotate}->{ids} = \@ids;
    my $try  = sub {
	return ATR::BioTables->getName_NextSerial($nametype, @_);
    };
    my $grab = sub {
	my ($pfx, @suff) = @_;
	foreach my $suff (@suff) {
	    my $id = ATR::BioTables->newName_idName($pfx.$suff, $nametype);
	    push @ids, "id_name $id = $pfx.$suff";
	    $self->assert_is_idnum($id, "Grab $pfx$suff");
	}
    };

    # Get first ever serial (if it's not one, need to pick a new prefix)
    my $first_X = $try->($pfx_X);
    $self->assert_str_equals($pfx_X . 1, $first_X);

    # Claim the one we were offered plus others
    $grab->($pfx_X, 1, 4, 5);

    $self->assert_str_equals($pfx_X . 2, $try->($pfx_X));
    $self->assert_str_equals($pfx_X . 7, $try->($pfx_X, [$pfx_X.2, $pfx_X.3, $pfx_X.6]));
    $self->assert_str_equals($pfx_X . 2, $try->($pfx_X));
    $grab->($pfx_X, 2, 3);

    $self->assert_str_equals($pfx_X . 6, $try->($pfx_X));
    $grab->($pfx_X, 6, 7, 8);

    # Now look at the shorter prefix
    $self->assert_str_equals($pfx . 3, $try->($pfx)); # XXX:USR this isn't great, probably need 'and not like' on the prefix count SQL

    # Ideally, this last test matches "${pfx}1"
}

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

sub test_genotype {
    my $self = shift;

    my @tgtr_ids = ( qw(  +/+  Sv 4 1 ),
		     qw(  +/+  dn 5 4 ),
		     qw(  +/dn dn 6 4 ),
		     qw( Sv/Sv Sv 2 1 ),
		   ); # XXX:TGTR data dependence...  we could instead poke junk loci + genos into our session

    while (my ($geno, $loc, $id_g, $id_l) = splice @tgtr_ids, 0, 4) {
	my $got_id = ATR::BioTables->getGenotypeId($geno, $loc);
	$self->assert_is_idnum($got_id);
	$self->assert_str_equals($id_g, $got_id);

	my $got_loc = ATR::BioTables->getGenotype_IdLocus($got_id);
	$self->assert_is_idnum($got_loc);
	$self->assert_str_equals($id_l, $got_loc);
    }

    # Check some details
    my $info  = ATR::BioTables->getGenotypeInfo( 6 );
    $self->assert_deep_equals({ name => '+/dn', id => 6,
				locus => { id => 4, short_name => 'dn' } },
			      $info);

    # Check the locus lister
    my @genos = ATR::BioTables->getGenotypes4Locus(1);
    my @L = (locus => { id => 1, short_name => 'Sv' });
    $self->assert_deep_equals([ sort { $a->{id} <=> $b->{id} } @genos ],
			      [ { id =>   1, name => "Sv/+", @L },
				{ id =>   2, name => "Sv/Sv", @L },
				{ id =>   3, name => "Sv/?", @L },
				{ id =>   4, name => "+/+", @L },
				{ id =>   9, name => "Xx", @L },
				{ id => 302, name => "sv/sv", @L },
				{ id => 303, name => "sv/+", @L },
				{ id => 391, name => "SV/+", @L },
			      ]);
}


#----------------------------------------------------------------------------
#
# DATERANGE and ATR::Date

sub test_daterange {
    my $self = shift;

    my @gt = ('2004-07-16 11:23:16',
	      '2004-12-20 15:18:27',
	      '2005-03-16 04:38:16'); # local times
    my @date = map { ATR::Date->newGT($_) } @gt;

    $self->assert_deep_equals([ '16/07/04',
				'20/12/04',
				'16/03/05'
			      ],
			      [ map { $_->getUI } @date ]);

    # Make start-end range
    my $id_DR = ATR::BioTables->newDateRange_Id(@date);
    $self->assert_is_idnum($id_DR);
    my @DR = ATR::BioTables->getDateRangeById($id_DR);
    $self->assert_str_equals( $gt[0], $DR[0]->getGT );
    $self->assert_str_equals( $gt[1], $DR[1]->getGT );

    # Make open-ended range
    my $id_DR2 = ATR::BioTables->newDateRange_Id($date[1], undef);
    $self->assert_str_not_equals($id_DR2, $id_DR);
    $self->assert_is_idnum($id_DR2);
    my @DR2 = ATR::BioTables->getDateRangeById($id_DR2);
    $self->assert_str_equals( $gt[1], $DR2[0]->getGT );
    $self->assert_null( $DR2[1] );

    # Try updating range end
    $self->assert_dies(qr/Cannot update DATERANGE/,
		       sub { ATR::BioTables->setDateRange_end($id_DR, $date[2]) });
    $self->assert_dies(qr/Invalid DATERANGE/,
		       sub { ATR::BioTables->setDateRange_end(0, $date[2]) });
    $self->assert_dies(qr/End is not after start/,
		       sub { ATR::BioTables->setDateRange_end($id_DR2, $date[0]) },
		       sub { ATR::BioTables->newDateRange_Id($date[2], $date[0]) });

    ATR::BioTables->setDateRange_end($id_DR2, $date[2]);
    my @DR2c = ATR::BioTables->getDateRangeById($id_DR2);
    $self->assert_str_equals( $gt[1], $DR2c[0]->getGT );
    $self->assert_str_equals( $gt[2], $DR2c[1]->getGT );

    # Check the comparisons
    my $gt0_same = ATR::Date->newGT('2004-07-16 11:23:16');
    $self->fail("Expected immutable objects, not cached ones") if $gt0_same == $date[0];
    $self->assert_str_equals( 0, ATR::Date->cmp($date[0], $gt0_same) );
    $self->assert_str_equals(-1, ATR::Date->cmp($date[0], $date[1]) );
    $self->assert_str_equals(-1, ATR::Date->cmp($date[1], $date[2]) );
    $self->assert_str_equals(-1,            $date[1]->cmp($date[2]) );
    $self->assert_str_equals( 1, ATR::Date->cmp($date[2], $date[1]) );
    $self->assert_str_equals( 1,            $date[2]->cmp($date[1]) );

    # Check parts conversion
    $self->assert_deep_equals([ 20, 12, 2004, 15,18,27 ],
			      [ $date[1]->getDMYHMSlocal ]);
}

sub test_date_guesser {
    my $self = shift;
    my @tests = (# input date, input time, expected output (regexp for error)
		 [ '1/2/3',	'teatime', qr/Please use HH:MM/ ],
		 [ 'other day',	'4:20', qr{Please use dd/mm/yyyy} ],
		 [ '1/2/3',	'4:20', '2003-02-01 04:20:00' ],
		 [ '2004.04',	'0:0', qr/must specify the day/ ],
		 [ '17/4/1962 5:23', '23:59:59', '1962-04-17 05:23:00' ],
		 [ '4/17/1962', '0:0', qr/American/ ],

		 # Following tests written 2005..  will break later due to year-distance
		 [ '3/4/9',	'1:2:5', '2009-04-03 01:02:05' ],
		 [ '3/4/99',	'1:2:5', '1999-04-03 01:02:05' ],
		 [ '3/4/59',	'1:2:5', qr/Please use four digit date/ ],
		 [ '12/30/08', '8:34:1', qr/American/ ],
		 [ '15/15/2007', '17:24:27', qr/Month '14' out of range 0\.\.11/ ],
		);
    for (my $i=0; $i<@tests; $i++) {
	my ($date, $time, $expect) = @{ $tests[$i] };
	my $do = sub {
	    return ATR::Date->new_GuessDate($date, $time)->getGT;
	};
	if (ref($expect) eq 'Regexp') {
	    $self->assert_dies($expect, $do, "test#$i");
	} else {
	    my $actual = $do->();
	    $self->assert_str_equals($expect, $actual, "test[$i]:\nwant '$expect',\n  got '$actual'");
	}
    }
}


1;
