package ATR::DatabaseTestCase;

use strict;
use warnings;
use base qw(McaTestCase);

=head1 NAME

ATR::DatabaseTestCase - base TestCase class for database tests

=head1 DESCRIPTION

Inherits from L<McaTestCase>.

Takes the responsibility for initialisation and tidy shutdown of
L<ATR::BioTables> and L<ATR::GTx> classes, just by being C<use>d.

=head1 CLASS FUNCTIONALITY

Using this module will initialise some ATR stuff and bodge about
untidy setup things.  Just once, just here.

=head1 METHODS

=cut


use ATR::BioTables;
use ATR::MicePE;
use Scalar::Util 'weaken';

{
    use SqlEngine2;
    no warnings;
    *SqlEngine2::cluck = sub { }; # cluck off silences our various deliberate failures
}

  ### these don't work: can't silence flush messages
  #
  # use GT::Physical::Entity;
  # use GT::Physical::Entity::Contents::Container;
  # use GT::Physical::Entity::Contents::Info::Container;
  # *GT::Physical::Entity::print = sub { };
  # *GT::Physical::Entity::Contents::Container::warn = sub { };
  # *GT::Physical::Entity::Contents::Info::Container::warn = sub { };

# Assorted gubbins to have our DBHs, SE2s and logins set before tests
# run; and then closed down nicely on exit.

my %pretest_rollback; # record checks that rollbacks didn't error;
		      # doesn't check whether/what they rolled back...

_init_atr();

sub _init_atr {
    $pretest_rollback{pre_bio} = eval { ATR::BioTables->rollbackTransaction; "ok" } || $@;
    $pretest_rollback{pre_gtx} = eval { ATR::GTx->rollbackTransaction; "ok" } || $@;

    ATR::BioTables->config('atr_testsuite');

    ATR::GTx->config(-login => 'atr_testsuite'); # XXX: need GTx::Constants to match this DB

    ATR::GTx->setUser( -idPerson => 24163 ); # XXX: do GTx->getUser(-email => $ENV{USER}) when it works
    ATR::GTx->setRole(ATR::GTx::ROLE_GENERAL); # XXX: Specific testcode role?
    ATR::GTx->setTeam(71);

    $pretest_rollback{post_bio} = eval { ATR::BioTables->rollbackTransaction; "ok" } || $@;
    $pretest_rollback{post_gtx} = eval { ATR::GTx->rollbackTransaction; "ok" } || $@;
}

END {
    local $SqlEngine2::verbosity = 0;
    ATR::MicePE->rollbackAll('testcase');
    ATR::BioTables->endDbh;
}

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

=head2 run_test method override

Scary thing to work around some incompatibility between CPAN L<Error>
module and ja1's L<Class::Throwable>

=cut

sub run_test {
    my ($self, @args) = @_;
    my $result = eval {
	$self->SUPER::run_test(@args);
    };
    my $prob = $@;
    return $result unless $prob;
    if (UNIVERSAL::isa($prob, 'Error')) {
#	warn "Rethrowing '$prob' which is a ".ref($prob);
	$prob->throw;
    } else {
	my $act = "Rethrown";
	$act = "Stringified from ".ref($prob)." and rethrown" if ref($prob);
	die "$act from ".__PACKAGE__.": $prob";
    }
}

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

=head2 set_up and tear_down

Provides base methods to ensure full rollback after each test.  Also
reduces SE2 verbosity for the duration of each test.

=cut

sub set_up {
    my $self = shift;
    $self->SUPER::set_up;
    $self->{old_verb} = $SqlEngine2::verbosity;
    $SqlEngine2::verbosity = 0;
}

sub tear_down {
    my $self = shift;

# XXX: Can we detect unflushed entities?  Provide method to do it?

    # If we died in the middle of rollback-worthy change, we don't
    # want the shutdown auto-commit
    ATR::MicePE->rollbackAll('testcase');

    $SqlEngine2::verbosity = $self->{old_verb};

    # rollback before other tear_downs, in case they die/fail
    $self->SUPER::tear_down;
}


=head2 DLO_ignore_class

For the benefit of the L<Devel::Leak::Object> testing code in the
superclass, we ignore:

 B::Deparse              Test::Unit::Assertion::CodeRef caches one
 SqlEngine2::Exception   stores last-seen of itself per package
 SqlEngine2              made and held by various classes
 DBI::st                 SqlEngine2 caches many

=cut

sub DLO_ignore_class { qw{DBI::st B::Deparse SqlEngine2::Exception SqlEngine2} }


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

=head1 test_early_rollbacks

Mini-test, ensures that rollbacks attempted during initialisation
didn't error.

Slightly untidy, in the respect that it bogusly bumps up the test
count for each subclass but only tests one thing.

=cut

sub test_early_rollbacks {
    my $self = shift;

    $self->assert_str_not_equals(__PACKAGE__, ref($self), "you only need to subclass this...");

    # We called rollback before & after calling config, check that
    # they didn't fail.
    foreach my $key (keys %pretest_rollback) {

	my $actual = delete $pretest_rollback{$key};
	# no need to repeat this for every subclasses

	$self->assert_str_equals("ok", $actual,
				 "Rollback test during initialisation, '$key'=$actual");
    }
}


1;
