Database-Join
view release on metacpan or search on metacpan
t/data-flow.t view on Meta::CPAN
# `my $db = $self->{_dbs}[$db_idx]` was computed unconditionally but is
# only used in the non-join-map/filters branch. Fixed by moving the
# assignment into the else branch.
#
# 2. D~ in _joined_query (annotated):
# $had_criteria[0] is written for every database, but the key-set
# resolution loop starts at i=1; when n==1, $had_criteria[0] is a
# permanent dead store.
#
# 3. Filter reference aliasing (FIXED):
# _copy_filters() deep-copies the caller's hashref at construction time.
# Post-construction mutation of the original hashref has no effect.
#
# All component databases are inline stubs (no SQLite, no disk I/O).
# ---------------------------------------------------------------------------
use Test::Most;
use Readonly;
use Scalar::Util qw(blessed refaddr weaken);
BEGIN {
eval { require Database::Abstraction };
plan skip_all => 'Database::Abstraction required' if $@;
plan tests => 88;
use_ok('Database::Join');
}
# ---------------------------------------------------------------------------
# Constants
# ---------------------------------------------------------------------------
Readonly::Scalar my $JC => 'entry';
Readonly::Scalar my $K_A => 'a1';
Readonly::Scalar my $K_B => 'a2';
Readonly::Scalar my $K_C => 'a3'; # secondary-only in some tests
# ---------------------------------------------------------------------------
# DFRecordingDA: records every criteria hashref passed to selectall_arrayref
# so DU tests can assert exactly what each database received.
# The `refaddr` of the received hashref is recorded alongside the hashref
# itself, enabling reference-identity checks separate from value checks.
# ---------------------------------------------------------------------------
## no critic (Modules::ProhibitMultiplePackages)
{
package DFRecordingDA;
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,
_received => [], # [ { hashref => ..., refaddr => ... }, ... ]
}, $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) = @_;
push @{ $self->{_received} }, {
hashref => $criteria,
refaddr => Scalar::Util::refaddr($criteria),
};
# Simple equality filter (no operator hashrefs needed for DU tests)
my @rows = @{ $self->{_rows} };
for my $col (keys %{ $criteria // {} }) {
my $v = $criteria->{$col};
@rows = grep {
defined $_->{$col} && defined $v && $_->{$col} eq $v
} @rows if defined $v;
}
return \@rows;
}
sub received { return $_[0]->{_received} }
sub clear_received { $_[0]->{_received} = []; return $_[0] }
sub DESTROY {}
}
# ---------------------------------------------------------------------------
# DFMinimalDA: lightweight stub without recording, for tests that only need
# data back and don't inspect the criteria sent to the DA.
# ---------------------------------------------------------------------------
{
package DFMinimalDA;
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 { return $_[0]->{_rows} } # always returns all rows
sub DESTROY {}
}
# ---------------------------------------------------------------------------
# DFCountingDA: records how many times selectall_arrayref is called.
# Applies simple equality filtering (same as DFRecordingDA) so filter criteria
# passed at spill time actually restrict the spilled rows.
# count() is defined directly in this package (not inherited) so that the
# 'auto' threshold probe's `defined &{"${pkg}::count"}` check is satisfied.
# ---------------------------------------------------------------------------
{
package DFCountingDA;
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,
_calls => 0,
}, $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 call_count { return $_[0]->{_calls} }
sub count { return scalar @{ $_[0]->{_rows} } } # direct def for auto-threshold
sub selectall_arrayref {
my ($self, $criteria) = @_;
$self->{_calls}++;
my @rows = @{ $self->{_rows} };
for my $col (keys %{ $criteria // {} }) {
my $v = $criteria->{$col};
@rows = grep {
defined $_->{$col} && defined $v && $_->{$col} eq $v
} @rows if defined $v;
}
return \@rows;
}
sub DESTROY {}
}
# ---------------------------------------------------------------------------
# DFNoTsDA: DA whose updated() returns undef (not a die/croak).
# _build_sqlite_cache stores undef for the timestamp.
# _cache_fresh: `$cached_ts = undef // next` skips the staleness check,
# keeping the cache valid indefinitely for this source.
# ---------------------------------------------------------------------------
{
package DFNoTsDA;
use parent -norequire, 'DFMinimalDA';
sub updated { return undef }
}
# ---------------------------------------------------------------------------
# Helpers
# ---------------------------------------------------------------------------
sub _two_db_join {
my (%opts) = @_;
my $prim = DFMinimalDA->new(
cols => ['entry', 'name'],
rows => [
{ entry => $K_A, name => 'Alpha' },
{ entry => $K_B, name => 'Beta' },
],
);
my $sec = DFMinimalDA->new(
cols => ['entry', 'score'],
rows => [
{ entry => $K_A, score => 10 },
{ entry => $K_B, score => 20 },
],
);
my $j = Database::Join->new(
databases => [$prim, $sec],
join_column => $JC,
%opts,
);
return ($j, $prim, $sec);
}
# ===========================================================================
# Section 1: Memoization cache lifecycle (DU for _col_cache and _schema_cache)
# ===========================================================================
subtest 'columns(): memoized — second call returns same arrayref' => sub {
# D: cache written on first call; U: cache read on second call; K: object destruction.
my ($j) = _two_db_join();
my $r1 = $j->columns();
my $r2 = $j->columns();
is refaddr($r1), refaddr($r2),
'repeated columns() calls return the same cached arrayref';
};
subtest 'schema(): memoized — second call returns same hashref' => sub {
my ($j) = _two_db_join();
my $s1 = $j->schema();
my $s2 = $j->schema();
is refaddr($s1), refaddr($s2),
'repeated schema() calls return the same cached hashref';
};
subtest 'remove_column: kills _col_cache (next call re-derives)' => sub {
# D: col_cache written during first columns() call
# K: col_cache killed by remove_column
# D: col_cache re-derived on next columns() call
# If the cache were NOT killed, the new arrayref would be the same ref as before.
my ($j) = _two_db_join();
my $r_before = $j->columns();
$j->remove_column('score');
my $r_after = $j->columns();
isnt refaddr($r_before), refaddr($r_after),
t/data-flow.t view on Meta::CPAN
};
subtest 'remove_column does not affect logger reference' => sub {
my ($j, $prim) = _two_db_join();
my $log = bless {}, 'FourthLogger';
$j->set_logger($log);
$j->remove_column('score');
is refaddr($j->{_logger}), refaddr($log),
'join _logger ref unchanged after remove_column';
is refaddr($prim->{logger}), refaddr($log),
'primary DA logger ref unchanged after remove_column';
};
# ===========================================================================
# Section 8: D~ anomaly in AUTOLOAD — dead store fix verification
# ===========================================================================
subtest 'AUTOLOAD join-path: correct values returned (D~ fix does not break it)' => sub {
# D~ fix: `my $db = $self->{_dbs}[$db_idx]` moved inside the else branch.
# Verify the join-path branch still works correctly after the refactoring.
# DFRecordingDA is used for the secondary because it actually applies criteria
# (equality filter), so the base filter { score => '10' } restricts to 1 row.
my $prim = DFMinimalDA->new(
cols => ['entry', 'name'],
rows => [
{ entry => $K_A, name => 'Alpha' },
{ entry => $K_B, name => 'Beta' },
],
);
my $sec = DFRecordingDA->new(
cols => ['entry', 'score'],
rows => [
{ entry => $K_A, score => '10' },
{ entry => $K_B, score => '20' },
],
);
# Activate filters so AUTOLOAD takes the join path (not $db->$col(@_)).
# filter score='10' on secondary: only entry $K_A survives → 1 merged row.
my $j = Database::Join->new(
databases => [$prim, $sec],
join_column => $JC,
filters => { 1 => { score => '10' } },
);
my $val = $j->name(entry => $K_A);
is $val, 'Alpha', 'AUTOLOAD join-path returns correct scalar value';
my @names = $j->name();
is scalar @names, 1, 'AUTOLOAD join-path list context: filter limits to 1 row';
};
subtest 'AUTOLOAD direct-path: $db resolved correctly after D~ fix' => sub {
# Without join_map or filters, AUTOLOAD must still resolve $db and delegate.
# Since DFMinimalDA does not implement AUTOLOAD itself, any column shortcut
# call would fail if the direct-delegation path were broken.
# We verify by using a custom DA that DOES define the column as a method.
{
package DirectDA;
use parent -norequire, 'Database::Abstraction';
sub new { bless { id=>'entry', _cols=>['entry','tag'], _rows=>[], _schema=>{}, _ts=>1 }, shift }
sub columns { return $_[0]->{_cols} }
sub schema { return {} }
sub updated { return 1 }
sub set_logger { $_[0]->{logger} = $_[1]; return $_[0] }
sub selectall_arrayref { return $_[0]->{_rows} }
sub tag { return 'direct-value' } # method that AUTOLOAD will delegate to
sub DESTROY {}
}
my $da = DirectDA->new();
my $j = Database::Join->new(databases => [$da], join_column => 'entry');
# No join_map or filters: AUTOLOAD takes the direct path and calls $da->tag()
my $val = $j->tag();
is $val, 'direct-value',
'AUTOLOAD direct-path correctly delegates to DA method after D~ fix';
};
# ===========================================================================
# Section 9: Single-DB DU — had_criteria[0] dead store (D~ annotated)
# ===========================================================================
subtest 'single-DB join: had_criteria[0] dead store does not cause runtime error' => sub {
# D~: $had_criteria[0] is written but never read when n==1 (key-set resolution
# loop starts at i=1, so i=0 is never processed there).
# Verify the query path is functionally correct despite the dead store.
my $da = DFRecordingDA->new(
cols => ['entry', 'val'],
rows => [
{ entry => $K_A, val => 'x' },
{ entry => $K_B, val => 'y' },
],
);
my $j = Database::Join->new(databases => [$da], join_column => $JC);
my $rows;
lives_ok { $rows = $j->selectall_arrayref(entry => $K_A) }
'single-DB join with criteria lives (no crash from dead had_criteria[0])';
is scalar @{$rows}, 1, 'correct row count from single-DB join';
is $rows->[0]{val}, 'x', 'correct row content';
};
subtest 'single-DB join: no-criteria query returns all rows cleanly' => sub {
my $da = DFMinimalDA->new(
cols => ['entry', 'x'],
rows => [
{ entry => $K_A, x => 1 },
{ entry => $K_B, x => 2 },
],
);
my $j = Database::Join->new(databases => [$da], join_column => $JC);
my $rows = $j->selectall_arrayref();
is scalar @{$rows}, 2,
'single-DB no-criteria query returns all rows (dead store harmless)';
};
# ===========================================================================
# Section 10: _col_rename / _col_unrename DU chains (collision_prefix flow)
#
# These two per-db arrayrefs are defined in _build_col_index when a
# collision_prefix is configured. They are then used in two distinct places:
# _col_rename → _joined_query merge (write merged{pub} from src{orig})
# _col_unrename → _partition_criteria (translate caller pub criterion → orig)
# ===========================================================================
subtest '_col_rename[i]: populated correctly at construction (orig → published)' => sub {
t/data-flow.t view on Meta::CPAN
# → secondary becomes an INNER JOIN partner → primary-only key is excluded.
my $prim = DFMinimalDA->new(
cols => ['entry', 'a'],
rows => [
{ entry => $K_A, a => 1 },
{ entry => $K_B, a => 2 }, # no matching secondary row
],
);
my $sec = DFMinimalDA->new(
cols => ['entry', 'b'],
rows => [{ entry => $K_A, b => 10 }],
);
my $j = Database::Join->new(
databases => [$prim, $sec],
join_column => $JC,
backend => 'sqlite',
join_type => 'left', # without criteria: LEFT JOIN → $K_B would appear
);
# Query-time criterion on secondary column: had_criteria[1] becomes true → INNER JOIN
my $rows = $j->selectall_arrayref(b => '10');
ok !(grep { $_->{entry} eq $K_B } @{$rows}),
'had_criteria[1]=true triggers INNER JOIN: primary-only key excluded (DU)';
is scalar @{$rows}, 1, 'only shared key returned under had_criteria-driven INNER JOIN';
};
subtest '@bind_vals: operator hashref values D in WHERE-build loop, U in execute()' => sub {
# DU: @bind_vals D'd by the WHERE-clause builder loop from operator hashref values.
# U: passed as positional params to $sth->execute(@bind_vals) — parameterized SQL,
# not string interpolation, so SQL injection via the value is impossible.
# The correct filter result confirms the full D→U chain is intact.
my $da = DFCountingDA->new(
cols => ['entry', 'score'],
rows => [
{ entry => $K_A, score => '10' },
{ entry => $K_B, score => '20' },
{ entry => $K_C, score => '30' },
],
);
my $j = Database::Join->new(
databases => [$da],
join_column => $JC,
backend => 'sqlite',
);
$j->selectall_arrayref(); # prime cache
# Operator hashref: score > 15 → bind_vals = ['15'], operator = '>'
my $rows = $j->selectall_arrayref(score => { '>' => '15' });
is scalar @{$rows}, 2,
'@bind_vals carries operator value to execute(): 2 rows have score > 15 (DU)';
ok !(grep { $_->{score} eq '10' } @{$rows}),
'score=10 excluded by operator bound value > 15 (bind_vals DU chain confirmed)';
};
# ---------------------------------------------------------------------------
# DFThrowUpdDA: DA whose updated() always throws.
# Used to verify that _joined_query / updated() resilience silently skips it.
# ---------------------------------------------------------------------------
{
package DFThrowUpdDA;
use parent -norequire, 'DFMinimalDA';
use Carp qw(croak);
sub updated { croak 'simulated updated() failure' }
sub DESTROY {}
}
# ---------------------------------------------------------------------------
# DFBareDA: duck-type DA with no Database::Abstraction parent and no updated()
# method. Proves that code paths that check `$db->can('updated')` (or use
# eval-guarded calls) handle a missing method without croaking.
# ---------------------------------------------------------------------------
{
package DFBareDA;
sub new {
my ($class, %args) = @_;
return bless {
_cols => $args{cols} // ['entry'],
_rows => $args{rows} // [],
}, $class;
}
sub columns { return $_[0]->{_cols} }
sub schema { return {} }
sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }
sub selectall_arrayref { return $_[0]->{_rows} }
sub DESTROY {}
# No updated() method -- deliberately omitted
}
# ---------------------------------------------------------------------------
# DFCountDA: like DFCountingDA but with a directly-defined count() so that the
# auto-backend threshold probe's `defined &{"${pkg}::count"}` check is true.
# Re-uses DFCountingDA's spill behaviour (equality filter + call counter).
# ---------------------------------------------------------------------------
{
package DFCountDA;
use parent -norequire, 'DFCountingDA';
sub count { return scalar @{ $_[0]->{_rows} } }
sub DESTROY {}
}
# ===========================================================================
# Section 17: _validate_pagination DU chains
#
# _validate_pagination is the single validation site for limit and offset.
# D: caller passes value → U: regex + numeric check → K (undef) if invalid,
# or survives to U in splice/SQL. All four branches are proven here.
# ===========================================================================
subtest '_validate_pagination D~K: negative limit undef\'d before splice (no truncation)' => sub {
# D: $limit = -1 → validation fires → K: undef'd.
# Consequence: splice is skipped (defined $limit is false), all rows returned.
my $da = DFMinimalDA->new(
cols => ['entry', 'val'],
rows => [
{ entry => $K_A, val => 'x' },
{ entry => $K_B, val => 'y' },
],
);
my $j = Database::Join->new(databases => [$da], join_column => $JC);
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, @_ };
my $rows = $j->selectall_arrayref(limit => -1);
ok(grep({ /limit/i } @warnings),
( run in 0.385 second using v1.01-cache-2.11-cpan-7da0f45c409 )