view release on metacpan or  search on metacpan

t/integration.t  view on Meta::CPAN

use Test::Most;
use Test::Returns;
use Test::Mockingbird;
use Test::Without::Module;
use Readonly;
use Scalar::Util qw(blessed refaddr);

BEGIN {
	eval { require DBD::SQLite; require DBI; require Database::Abstraction };
	plan skip_all => 'DBD::SQLite, DBI, and Database::Abstraction required' if $@;
	plan tests => 104;
	use_ok('Database::Join');
}

use DBI;
use File::Temp qw(tempdir);

# ---------------------------------------------------------------------------
# SQLite-backed DA stubs.  -norequire because Database::Abstraction was
# already require()d in the BEGIN block above.
#
# Class-name last-component must match the SQL filename exactly (case-sensitive).
# Using all-lowercase names to match the intcust.sql / intscore.sql filenames.
# ---------------------------------------------------------------------------
{
	package Database::intcust;
	use parent -norequire, 'Database::Abstraction';
}
{
	package Database::intscore;
	use parent -norequire, 'Database::Abstraction';
}
{
	package Database::intregion;
	use parent -norequire, 'Database::Abstraction';
}

# ---------------------------------------------------------------------------
# InMemDA: in-process stub for tests that do not need SQLite.
# Implements the subset of the Database::Abstraction API that Database::Join
# calls: columns, schema, updated, set_logger, selectall_arrayref.
# Operator hashrefs (>, <, >=, <=, !=) are supported for numeric columns.
# ---------------------------------------------------------------------------
{
	package InMemDA;
	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_000_000,
		}, $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} };
		for my $col (keys %{ $criteria // {} }) {
			my $val = $criteria->{$col};
			if (ref($val) eq 'HASH') {
				for my $op (keys %{$val}) {
					my $v = $val->{$op};
					if    ($op eq '>')  { @rows = grep { defined $_->{$col} && $_->{$col} >  $v } @rows }
					elsif ($op eq '<')  { @rows = grep { defined $_->{$col} && $_->{$col} <  $v } @rows }
					elsif ($op eq '>=') { @rows = grep { defined $_->{$col} && $_->{$col} >= $v } @rows }
					elsif ($op eq '<=') { @rows = grep { defined $_->{$col} && $_->{$col} <= $v } @rows }
					elsif ($op eq '!=') { @rows = grep { defined $_->{$col} && $_->{$col} != $v } @rows }
				}
			} else {
				@rows = grep { defined $_->{$col} && $_->{$col} eq $val } @rows;
			}
		}
		return \@rows;
	}

	sub DESTROY {}
}

# ---------------------------------------------------------------------------
# Fake logger: records calls so that set_logger propagation can be verified
# without triggering real logging side-effects.
# Database::Abstraction calls $logger->debug/info/warn/error at query time,
# so all four levels must exist.
# ---------------------------------------------------------------------------
{
	package IntFakeLogger;
	sub new   { return bless { _calls => [] }, shift }
	sub debug { push @{$_[0]->{_calls}}, ['debug', $_[1]] }
	sub info  { push @{$_[0]->{_calls}}, ['info',  $_[1]] }
	sub warn  { push @{$_[0]->{_calls}}, ['warn',  $_[1]] }
	sub error { push @{$_[0]->{_calls}}, ['error', $_[1]] }
}

# ---------------------------------------------------------------------------
# Constants -- no magic numbers or strings in test assertions.
# ---------------------------------------------------------------------------
Readonly::Scalar my $JC         => 'entry';
Readonly::Scalar my $ALICE_KEY  => 'c001';
Readonly::Scalar my $BOB_KEY    => 'c002';
Readonly::Scalar my $CAROL_KEY  => 'c003';
Readonly::Scalar my $ALL_CUST   => 3;   # total rows in intcust
Readonly::Scalar my $ALL_SCORED => 3;   # total rows in intscore
Readonly::Scalar my $REGIOND    => 2;   # rows in intregion (c003 absent)
Readonly::Scalar my $GOLD_COUNT => 2;   # Alice and Carol are tier=gold

# ---------------------------------------------------------------------------
# SQLite fixture setup
#
#   intcust:   entry | name  | email                | tier
#              c001  | Alice | alice@example.com    | gold
#              c002  | Bob   | bob@example.com      | silver
#              c003  | Carol | carol@example.com    | gold

t/integration.t  view on Meta::CPAN

# count() on the SQLite path executes SELECT COUNT(*) against the cached join
# tables rather than fetching all rows.  The result must agree with the length
# of selectall_arrayref for equivalent criteria.
# ===========================================================================

subtest 'count(): SQLite backend count agrees with selectall_arrayref length (no criteria)' => sub {
	plan tests => 1;
	# Reuse the s18 fixtures (Alpha/Beta/Gamma with tier and score) which are
	# already built -- no new fixture needed.
	my $j = Database::Join->new(
		databases => [$s18_db_a, $s18_db_b], join_column => $JC,
		backend   => 'sqlite',
	);
	is($j->count(),
	   scalar @{ $j->selectall_arrayref() },
	   'count() on SQLite path equals the length of selectall_arrayref() with no criteria');
};

subtest 'count(): SQLite backend count with criteria agrees with filtered selectall_arrayref' => sub {
	plan tests => 1;
	my $j = Database::Join->new(
		databases => [$s18_db_a, $s18_db_b], join_column => $JC,
		backend   => 'sqlite',
	);
	my $filtered = $j->selectall_arrayref(tier => 'gold');
	is($j->count(tier => 'gold'),
	   scalar @{$filtered},
	   'count(tier => gold) on SQLite path equals the filtered selectall_arrayref length');
};

diag('section 26 done') if $ENV{TEST_VERBOSE};

# ===========================================================================
# SECTION 27 -- updated() resilience: missing and throwing implementations (2 subtests)
#
# updated() silently skips component DAs that do not implement updated() or
# whose updated() throws an exception.  Returns undef when no component DA
# implements updated() at all.  Regression for the 0.007.0 fix.
# ===========================================================================

# IntBareDA: a minimal duck-type DA with NO updated() method.  Has only the
# two methods Database::Join requires by its duck-type guard: columns() and
# selectall_arrayref().
{
	package IntBareDA;
	sub new {
		my ($class, %args) = @_;
		return bless { _cols => $args{cols} // [], _rows => $args{rows} // [] }, $class;
	}
	sub columns            { return $_[0]->{_cols} }
	sub schema             { return {} }
	sub selectall_arrayref { return $_[0]->{_rows} }
	sub DESTROY {}
}

# IntThrowUpdDA: inherits from InMemDA but overrides updated() to die,
# exercising the "skip DAs whose updated() throws" branch.
{
	package IntThrowUpdDA;
	our @ISA = ('InMemDA');
	sub updated { die "simulated updated() failure\n" }
	sub DESTROY {}
}

subtest 'updated(): returns undef when no component DA implements updated()' => sub {
	plan tests => 1;
	# IntBareDA has no updated() method; the join must return undef, not croak.
	my $db = IntBareDA->new(
		cols => [$JC, 'x'],
		rows => [ { entry => 'K', x => 1 } ],
	);
	my $j = Database::Join->new(databases => [$db], join_column => $JC);
	ok(!defined $j->updated(),
		'updated() returns undef when no component DA implements updated()');
};

subtest 'updated(): silently skips a component DA whose updated() throws' => sub {
	plan tests => 2;
	# One good DA with a known timestamp; one that throws from updated().
	# The join must return the good timestamp without propagating the exception.
	Readonly::Scalar my $GOOD_TS => 9_999_999;
	my $good_db = InMemDA->new(
		cols    => [$JC, 'x'],
		rows    => [ { entry => 'K', x => 1 } ],
		updated => $GOOD_TS,
	);
	my $bad_db = IntThrowUpdDA->new(
		cols    => [$JC, 'y'],
		rows    => [ { entry => 'K', y => 2 } ],
		updated => 0,   # irrelevant -- updated() will die before returning
	);
	my $j = Database::Join->new(databases => [$good_db, $bad_db], join_column => $JC);
	my $ts;
	lives_ok { $ts = $j->updated() }
		'updated() does not propagate a die thrown by a component DA';
	is($ts, $GOOD_TS,
		'updated() returns the good component timestamp, silently skipping the one that threw');
};

diag('section 27 done -- integration tests complete') if $ENV{TEST_VERBOSE};