view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

# other public methods are tested on real Database::Join objects built with
# inline MinimalDA mocks.
#
# MinimalDA is an in-process stub that inherits from Database::Abstraction
# purely to satisfy the isa() check.  Its selectall_arrayref, columns(), and
# schema() are configurable at construction time so each subtest can control
# exactly what the component database returns.
#
# Test::Mockingbird is used to mock List::Util::max (used by updated()) and
# to spy on internal call chains.  Test::Returns validates return-type
# contracts.  Test::Memory::Cycle verifies no circular references exist.
# ---------------------------------------------------------------------------

use Test::Most;
use Test::Mockingbird;
use Test::Returns;
use Test::Memory::Cycle;
use Readonly;
use Scalar::Util qw(blessed refaddr);

BEGIN {
	eval { require Database::Abstraction };
	plan skip_all => 'Database::Abstraction required' if $@;
	plan tests => 180;
	use_ok('Database::Join');
}

# ---------------------------------------------------------------------------
# Constants -- prevent magic strings from appearing in the body below
# ---------------------------------------------------------------------------
Readonly::Scalar my $JC       => 'entry';          # canonical join column
Readonly::Scalar my $JC_ALT   => 'statecode';      # alternative join_column name
Readonly::Scalar my $JC_ALIAS => 'id';             # local alias used by DB 1 in join_map tests
Readonly::Scalar my $COL_A    => 'name';
Readonly::Scalar my $COL_B    => 'score';
Readonly::Scalar my $COL_C    => 'tier';
Readonly::Scalar my $TS_A     => 1_000_000;
Readonly::Scalar my $TS_B     => 2_000_000;

# ---------------------------------------------------------------------------
# MinimalDA: inline Database::Abstraction subclass used as a mock component.
# Configurable columns/rows/schema/updated at construction time.
# ---------------------------------------------------------------------------
{
	package MinimalDA;
	use parent -norequire, 'Database::Abstraction';

	sub new {
		my ($class, %args) = @_;
		return bless {
			id      => $args{id}      // 'entry',
			_cols   => $args{cols}    // ['entry'],
			_rows   => $args{rows}    // [],
			_schema => $args{schema}  // {},
			_ts     => $args{updated} // 1,
		}, $class;
	}

	sub columns         { return $_[0]->{_cols} }
	sub schema          { return $_[0]->{_schema} }
	sub updated         { return $_[0]->{_ts} }
	sub set_logger      { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		my @rows = @{ $self->{_rows} };
		# Simple equality filter for tests that need it
		for my $col (keys %{ $criteria // {} }) {
			my $val = $criteria->{$col};
			next if ref $val;
			@rows = grep { defined $_->{$col} && $_->{$col} eq $val } @rows;
		}
		return \@rows;
	}
	sub DESTROY {}
}

# ---------------------------------------------------------------------------
# WhiteBox shim: subclass that exposes protected methods for unit testing.
# Protected subs check caller; calling them through a subclass passes the check.
# ---------------------------------------------------------------------------
{
	package Database::Join::WhiteBox;
	use parent -norequire, 'Database::Join';
	sub expose_msg              { shift; Database::Join::_msg(@_) }
	sub expose_merge_criteria   { shift; Database::Join::_merge_criteria(@_) }
	sub expose_parse_query_args { my $self = shift; return $self->_parse_query_args(@_) }
	sub expose_partition        { my $self = shift; return $self->_partition_criteria(@_) }
	sub expose_fetch_indexed    { my $self = shift; return $self->_fetch_indexed(@_) }
	sub expose_joined_query      { my $self = shift; return $self->_joined_query(@_) }
	sub expose_err               { my $self = shift; return $self->_err(@_) }
	sub expose_build_col_index   { my $self = shift; return $self->_build_col_index(@_) }
	sub expose_cache_fresh        { my $self = shift; return $self->_cache_fresh(@_) }
	sub expose_build_sqlite_cache { my $self = shift; return $self->_build_sqlite_cache(@_) }
	sub expose_joined_query_array     { my $self = shift; return $self->_joined_query_array(@_) }
	sub expose_validate_schema_types  { my $self = shift; return $self->_validate_schema_types(@_) }
}

# Convenience builder for a bare WhiteBox skeleton (no databases needed for
# pure-helper tests that don't touch _dbs).
sub _bare_whitebox {
	my (%extra) = @_;
	return bless {
		_join_col         => $JC,
		_join_type        => 'left',
		_join_map         => {},
		_filters          => {},
		_dbs              => [],
		_col_db           => {},
		_db_cols          => [],
		_removed_cols     => {},
		_col_cache        => undef,
		_schema_cache     => undef,
		_autoload_pk      => $JC,
		_logger           => undef,
		_i18n             => undef,
		_collision_prefix => {},
		_col_rename       => [],   # arrayref-of-hashrefs: orig_col => published_col per DB
		_col_unrename     => [],   # arrayref-of-hashrefs: published_col => orig_col per DB
		%extra,
	}, 'Database::Join::WhiteBox';
}

t/function.t  view on Meta::CPAN

	# If a second database has been added since the cache was built, the cached
	# n will be smaller than the current @_dbs count, forcing a rebuild.
	my $db = MinimalDA->new(cols => [$JC, $COL_A], rows => []);
	my $wb = Database::Join::WhiteBox->new(databases => [$db], join_column => $JC);
	# Fake a cache that claims n=0 while _dbs now has 1 source.
	$wb->{_sqlite_cache} = { n => 0, updated => {}, dbh => bless({}, 'FakeDBH') };
	ok(!$wb->expose_cache_fresh(),
		'_cache_fresh returns 0 when cached n differs from current database count');
};

subtest '_cache_fresh: returns 0 when DBI handle is inactive' => sub {
	plan tests => 1;
	# Build a real cache so we have a genuine DBI handle, then disconnect it to
	# simulate a dropped connection.  _cache_fresh must return 0.
	my $db = MinimalDA->new(
		cols    => [$JC, $COL_A],
		rows    => [ { entry => 'K1', name => 'Alice' } ],
		updated => $TS_A,
	);
	my $wb = Database::Join::WhiteBox->new(
		databases   => [$db],
		join_column => $JC,
		backend     => 'sqlite',
	);
	$wb->expose_build_sqlite_cache();
	# Disconnect the handle to make it inactive.
	$wb->{_sqlite_cache}{dbh}->disconnect();
	ok(!$wb->expose_cache_fresh(),
		'_cache_fresh returns 0 when the cached DBI handle is no longer Active');
};

subtest '_cache_fresh: returns 0 when a captured timestamp has changed' => sub {
	plan tests => 2;
	# Build the cache with timestamp TS_A.  Then bump the DA timestamp to TS_B.
	# _cache_fresh must detect the mismatch and return 0.
	my $db = MinimalDA->new(
		cols    => [$JC, $COL_A],
		rows    => [ { entry => 'K1', name => 'Alice' } ],
		updated => $TS_A,
	);
	my $wb = Database::Join::WhiteBox->new(
		databases   => [$db],
		join_column => $JC,
		backend     => 'sqlite',
	);
	$wb->expose_build_sqlite_cache();
	ok($wb->expose_cache_fresh(), 'cache is fresh immediately after build');
	# Simulate the source being updated.
	$db->{_ts} = $TS_B;
	ok(!$wb->expose_cache_fresh(),
		'_cache_fresh returns 0 after source updated() timestamp changes');
};

subtest '_cache_fresh: returns 1 when source has no updated() (timestamp skipped)' => sub {
	plan tests => 1;
	# A source DA without an updated() method should not invalidate the cache.
	# _cache_fresh skips the timestamp check for it, leaving the cache valid.
	{
		package MinimalDA::NoTS;
		use parent -norequire, 'MinimalDA';
		sub updated { die 'no updated()' }   # simulates a DA that croaks
	}
	my $db = bless MinimalDA->new(cols => [$JC], rows => []), 'MinimalDA::NoTS';
	my $wb = Database::Join::WhiteBox->new(
		databases   => [$db],
		join_column => $JC,
		backend     => 'sqlite',
	);
	$wb->expose_build_sqlite_cache();
	# _sqlite_cache{updated}{0} is undef because updated() died → next → skip.
	ok($wb->expose_cache_fresh(),
		'_cache_fresh returns 1 when source has no working updated()');
};

subtest '_cache_fresh: returns 1 when all conditions pass' => sub {
	plan tests => 2;
	my $db = MinimalDA->new(
		cols    => [$JC, $COL_A],
		rows    => [ { entry => 'K1', name => 'Alice' } ],
		updated => $TS_A,
	);
	my $wb = Database::Join::WhiteBox->new(
		databases   => [$db],
		join_column => $JC,
		backend     => 'sqlite',
	);
	$wb->expose_build_sqlite_cache();
	ok($wb->expose_cache_fresh(), 'cache is fresh immediately after build (first check)');
	ok($wb->expose_cache_fresh(), 'cache remains fresh on a second call without any change');
};

# ===========================================================================
# SECTION 33 -- _build_sqlite_cache (4 tests)
#
# _build_sqlite_cache spills each source into a File::Temp SQLite file.
# These tests verify: the cache structure is populated, rows are present,
# updated() timestamps are recorded, and rebuilding disconnects the old handle.
# ===========================================================================

subtest '_build_sqlite_cache: populates _sqlite_cache with required keys' => sub {
	plan tests => 4;
	my $db = MinimalDA->new(
		cols    => [$JC, $COL_A],
		rows    => [ { entry => 'K1', name => 'Alice' } ],
		updated => $TS_A,
	);
	my $wb = Database::Join::WhiteBox->new(
		databases   => [$db],
		join_column => $JC,
		backend     => 'sqlite',
	);
	$wb->expose_build_sqlite_cache();
	my $cache = $wb->{_sqlite_cache};
	ok(defined $cache,                    '_sqlite_cache is set after build');
	ok(defined $cache->{dbh},             '_sqlite_cache has a dbh');
	ok(defined $cache->{tmpfile},         '_sqlite_cache has a tmpfile');
	is($cache->{n}, 1,                    '_sqlite_cache{n} matches source count (1)');
};

subtest '_build_sqlite_cache: spilled rows are queryable via the cached DBI handle' => sub {
	plan tests => 2;