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 => 119;
	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(@_) }
}

# 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,
		%extra,
	}, 'Database::Join::WhiteBox';
}

# Convenience: build a standard two-DB join for integration-style subtests
sub _make_join {
	my (%opts) = @_;
	my $db_a = MinimalDA->new(
		cols   => [$JC, $COL_A, $COL_C],
		rows   => [