view release on metacpan or  search on metacpan

t/logic.t  view on Meta::CPAN

#!/usr/bin/env perl
# t/logic.t -- Formal logic proofs for Database::Join
#
# Proves: truth tables, state invariants, and contradiction trapping.
# Coverage:
#   L01  Key-set resolution truth table (join_type x had_criteria -- 6 paths)
#   L02  De Morgan complementarity of the key-set gate
#   L03  Syllogism: filter forces inner-join semantics regardless of join_type
#   L04  _merge_criteria truth table (4 input-type combinations)
#   L05  _partition_criteria routing invariants
#   L06  collision_prefix boolean gate (index > 0 guard)
#   L07  AUTOLOAD dispatch logic (join_map|filters => full join path)
#   L08  _cache_fresh conditions (observable via DA call counts)
#   L09  columns() invariants: always sorted, join_column always present
#   L10  Memoisation cache invalidation state machine
#   L11  Contradiction trapping (impossible states croak immediately)
#   L12  remove_column: join_column is irremovable (contradiction proof)
#   L13  _copy_criteria deep-copy isolation (post-construction mutation proof)
#   L23  $ob_override boolean gate truth table (join_col vs non-join-col sort_by)
#   L24  Non-commutativity of offset ∘ limit (offset applied before limit)
#   L25  Schwarzian undef coercion (undef ob_col value sorted as empty string)
#   L26  reverse correctness for join_col DESC (O(R) reverse == explicit Schwarzian)
#   L27  _validate_pagination predicate truth table (De Morgan for limit / offset)

use strict;
use warnings;

use Test::Most tests => 94;
use Readonly;

use lib 't/lib';
use_ok('Database::Join') or BAIL_OUT('Database::Join failed to load');

# ===========================================================================
# Inline stub DA -- self-contained, no disk I/O.
# Supports equality and numeric-operator filtering on its rows.
# ===========================================================================

{
	package LogicDA;
	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 call_count { return $_[0]->{_calls} }
	sub set_logger { $_[0]->{logger} = $_[1]; return $_[0] }

	# Defined directly so defined(&{"LogicDA::count"}) is TRUE -- needed for
	# backend='auto' threshold probe which distinguishes own-defined vs inherited.
	sub count { return scalar @{ $_[0]->{_rows} } }

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		$self->{_calls}++;
		my @rows = @{ $self->{_rows} };
		for my $col (keys %{ $criteria // {} }) {
			my $v = $criteria->{$col};
			if (ref($v) eq 'HASH') {
				for my $op (keys %{$v}) {
					my $lim = $v->{$op};
					if    ($op eq '>')  { @rows = grep { defined $_->{$col} && $_->{$col} >  $lim } @rows }
					elsif ($op eq '<')  { @rows = grep { defined $_->{$col} && $_->{$col} <  $lim } @rows }
					elsif ($op eq '>=') { @rows = grep { defined $_->{$col} && $_->{$col} >= $lim } @rows }
					elsif ($op eq '<=') { @rows = grep { defined $_->{$col} && $_->{$col} <= $lim } @rows }
					elsif ($op eq '!=') { @rows = grep { defined $_->{$col} && $_->{$col} != $lim } @rows }
					elsif ($op eq '=')  { @rows = grep { defined $_->{$col} && $_->{$col} == $lim } @rows }
				}
			} elsif (defined $v) {
				@rows = grep { defined $_->{$col} && $_->{$col} eq $v } @rows;
			}
		}
		return \@rows;
	}

	sub DESTROY {}
}

# DA that returns undef from updated() -- used for cache-skip tests.
{
	package LogicNoTsDA;
	use parent -norequire, 'LogicDA';
	sub updated { return undef }
}

# Minimal stub that has selectall_arrayref but NOT columns().
# Used by L14 to prove that the P1 invariant is enforced at every entry point.
{
	package NoCols;
	sub new     { bless {}, shift }
	sub selectall_arrayref { return [] }
	sub DESTROY {}
}

# LogicBareDA: duck-type DA with NO updated() method at all.
# Used by L22 to prove that updated() returns undef when no component has timestamps.
{
	package LogicBareDA;
	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() -- deliberately absent
}

# LogicThrowUpdDA: DA whose updated() throws unconditionally.
# Used by L22 to prove that throwing DAs are skipped and do not propagate errors.
{
	package LogicThrowUpdDA;
	use parent -norequire, 'LogicDA';
	use Carp qw(croak);
	sub updated { croak 'simulated updated() failure' }
	sub DESTROY {}
}

# ===========================================================================
# Shared fixtures: primary has keys {A,B,C}; secondary has keys {B,D}.
# ===========================================================================

Readonly::Hash my %ROW => (
	pA => { entry => 'A', name  => 'alice' },
	pB => { entry => 'B', name  => 'bob'   },
	pC => { entry => 'C', name  => 'carol' },
	sB => { entry => 'B', score => 10      },
	sD => { entry => 'D', score => 20      },
);

sub _prim { LogicDA->new(cols => ['entry','name'],  rows => [@ROW{qw(pA pB pC)}]) }
sub _sec  { LogicDA->new(cols => ['entry','score'], rows => [@ROW{qw(sB sD)}])    }

sub _build_join {
	my (%extra) = @_;
	return Database::Join->new(
		databases   => [_prim(), _sec()],
		join_column => 'entry',
		backend     => 'array',
		%extra,
	);
}

sub _keys { [ sort map { $_->{entry} } @{ $_[0] } ] }

# ===========================================================================
# L01: Key-set resolution truth table
#
# Gate formula: had_criteria[i] OR join_type eq 'inner' => INTERSECT
# Otherwise:   left => primary unchanged  |  outer => UNION
#
# Truth table (had_criteria h, join_type j):
#   h=0, j=left  => key_set = primary = {A,B,C}   (3 rows)
#   h=0, j=inner => key_set = {A,B,C} ∩ {B,D} = {B} (1 row)
#   h=0, j=outer => key_set = {A,B,C} ∪ {B,D} = {A,B,C,D} (4 rows)
#   h=1, j=left  => gate TRUE => intersect => {A,B,C} ∩ {B} = {B} (1 row)
#   h=1, j=inner => gate TRUE => intersect => {B} (1 row)
#   h=1, j=outer => gate TRUE => intersect, not union => {B} (1 row)
# ===========================================================================

subtest 'L01: left + no secondary criteria => primary key-set unchanged' => sub {
	plan tests => 2;
	my $rows = _build_join(join_type => 'left')->selectall_arrayref();
	is(scalar @{$rows}, 3, 'left+nocrit: 3 rows');
	is_deeply(_keys($rows), [qw(A B C)], 'left+nocrit: keys={A,B,C}');
};

subtest 'L01: inner + no criteria => intersection' => sub {
	plan tests => 2;
	my $rows = _build_join(join_type => 'inner')->selectall_arrayref();
	is(scalar @{$rows}, 1, 'inner+nocrit: 1 row');
	is_deeply(_keys($rows), ['B'], 'inner+nocrit: keys={B}');
};

subtest 'L01: outer + no criteria => union' => sub {