The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl -T

use strict;
use warnings;

use DBI;
use DBIx::ScopedTransaction;
use Test::Exception;
use Test::FailWarnings -allow_deps => 1;
use Test::More tests => 8;

use lib 't/lib';
use LocalTest;


my $dbh = LocalTest::ok_database_handle();

ok(
	bless( $dbh, 'DBI::db::Test' ),
	'Override rollback() method of the underlying database handle.',
);

my $destroy_logs = [];
ok(
	local $DBIx::ScopedTransaction::DESTROY_LOGGER = sub
	{
		my ( $messages ) = @_;
		push( @$destroy_logs, @$messages );
	},
	'Set up capture of messages from DBIx::ScopedTransaction::DESTROY.',
);

{
	my $transaction;
	lives_ok(
		sub
		{
			$transaction = DBIx::ScopedTransaction->new( $dbh );
		},
		'Create a transaction object.',
	);
}
note('Transaction object should have gone out of scope now.');

isnt(
	scalar( @$destroy_logs ),
	0,
	'Detected issues when transaction object was destroyed.',
) || diag( explain( $destroy_logs ) );

is(
	scalar(
		grep { $_ =~ /\ATransaction object created at .*? is going out of scope, but the transaction has not been committed or rolled back; check logic\.\Z/ }
		@$destroy_logs
	),
	1,
	'Found warning explaining where the transaction was started and that is was not completed properly.',
) || diag( explain( $destroy_logs ) );

is(
	scalar( grep { $_ eq 'Could not roll back transaction to resolve the issue.' } @$destroy_logs ),
	1,
	'Found warning to explain the rollback initiated by the object failed.',
) || diag( explain( $destroy_logs ) );

is(
	scalar( @$destroy_logs ),
	2,
	'No unexpected issues reported.',
) || diag( explain( $destroy_logs ) );


# Subclass DBI::db and override rollback() to make it fail.
package DBI::db::Test;

use base 'DBI::db';

sub rollback
{
	return 0;
}

1;