package ATR::GTTest;

use strict;
use warnings;

use base qw(ATR::DatabaseTestCase); # ensures GT is loaded

use B 'svref_2object'; # for REFCNT
use GTx::Constants;

sub set_up {
    my $self = shift;
    $self->SUPER::set_up;

    foreach my $pkg ("GT/Physical/Entity.pm",
		     "GTx.pm",
		     "GTx/Constants.pm",
		     "Class/Abstract/Bean.pm") {
	$self->{annotate}->{"INC{$pkg}"} = $INC{$pkg};
    }
}

sub test_attrib_dates {
    my $self = shift;

    my $get_vals = sub {
	my @vals;
	foreach my $key ('_InitDate', '_EndDate') {
	    push @vals, GT::Physical::Entity::Contents::Attribute->_default($key);
	}
	return @vals;
    };

    my @first = $get_vals->();
    sleep 1;
    my @next = $get_vals->();

    my $date_pat = qr/^\d{4}-\d{2}-\d{2}.../;
    for (my $i=0; $i<@first; $i++) {
	$self->assert_matches($date_pat, $first[$i]);
	$self->assert_matches($date_pat, $next[$i]);
	$self->assert_str_not_equals($first[$i], $next[$i]);
    }
}


sub test_symtable_leak {
    my $self = shift;

    my $count = sub { svref_2object($_[0])->REFCNT };

    my $attrib = GT::Physical::Entity::Contents::Attribute->create();
    my $first = $count->($attrib);

    # Caution if we see autoloaded methods already in place
    # See how it goes...
    foreach my $method (qw(setIsCurrent setEndDate setRemark)) {
	$self->fail("Can't check symbol table leak for $method, someone got here first")
	  if $attrib->can($method);
    }

    # Hammer the setter methods, they cause the problem iff we're the first caller
    $attrib->setIsCurrent(0);
    $attrib->setEndDate( $attrib->getInitDate );
    $attrib->setRemark("wibble");

    my $next = $count->($attrib);
    $self->assert_str_equals($first, $next);
    $self->assert_str_equals(1, $next);
}

sub test_gtx_constants {
    my $self = shift;

    # GTx::			TGTR-value
    my @lines = split /\n/, <<consts;
REASON_IDENTIFIED_BY		15
REASON_DERIVED_FROM		16
REASON_CONTAINS			 7
CONT_TYPE_ATR_NAME		27
ENT_TYPE_MOUSE			25
ENT_TYPE_MOUSE_MATING_CARD	26
ENT_TYPE_MOUSE_WEANING_CARD	27
ATT_TYPE_MOUSE			23
ATT_TYPE_WEANING_CARD		38
ATT_TYPE_ALIVE_SINCE		35
ATT_TYPE_ALIVE_UNTIL		36
ATT_TYPE_WEANING_CARD		38
consts
    # nb. this probably doesn't cover all the GTx::Constants used in the code,
    # but it's representative

    foreach my $line (@lines) {
	my ($const, $tgtr) = split /\s+/, $line;
	my $expect = $tgtr;
	my $actual = eval "GTx::$const()";
	$actual = "[missing]" if !$actual && $@;
	$self->assert_str_equals($expect, $actual,
				 "GTx::$const, want $expect got $actual");
    }
}


1;
