view release on metacpan or  search on metacpan

t/transition.t  view on Meta::CPAN

#!/usr/bin/perl

# t/transition.t — Finite State Machine transition tests for Database::Join.
#
# Validates every documented state transition derived from the Z calculus
# FORMAL SPECIFICATION in lib/Database/Join.pm:
#
#   FSM 1 — Object Lifecycle  (ΔDatabase_Join / ΞDatabase_Join schemas)
#   FSM 2 — SQLite Cache Lifecycle  (_cache_fresh / _build_sqlite_cache)
#   FSM 3 — Column Visibility  (ΔDatabase_Join RemoveColumn schema)
#
# Each subtest is named after the transition it covers:
#   "State: <source> -> Trigger: <op> -> State: <destination>"

use strict;
use warnings;

use Test::Most tests => 54;
use Readonly;
use Scalar::Util qw(blessed refaddr);

use_ok('Database::Join');

# ---------------------------------------------------------------------------
# Inline test doubles
# ---------------------------------------------------------------------------

{
	package TransDA;
	use parent -norequire, 'Database::Abstraction';
	sub new {
		my ($class, %a) = @_;
		return bless {
			cols    => $a{cols}    // ['entry'],
			rows    => $a{rows}    // [],
			id      => $a{id}      // 'entry',
			schema  => $a{schema}  // {},
			updated => $a{updated} // 1,
			_calls  => 0,
			_logger => undef,
		}, $class;
	}
	sub columns    { return $_[0]->{cols} }
	sub schema     { return $_[0]->{schema} // {} }
	sub updated    { return $_[0]->{updated} }
	sub call_count { return $_[0]->{_calls} }
	sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub selectall_arrayref {
		my ($self, $crit) = @_;
		$self->{_calls}++;
		$crit //= {};
		my @out;
		ROW: for my $row (@{ $self->{rows} }) {
			for my $col (keys %{$crit}) {
				my $v = $crit->{$col};
				if (ref($v) eq 'HASH') {
					for my $op (keys %{$v}) {
						my $rhs = $v->{$op};
						if ($op eq '>')  { next ROW unless defined $row->{$col} && $row->{$col} >  $rhs }
						elsif ($op eq '<') { next ROW unless defined $row->{$col} && $row->{$col} < $rhs }
					}
				} elsif (defined $v) {
					next ROW unless defined $row->{$col} && $row->{$col} eq $v;
				}
			}
			push @out, { %{$row} };
		}
		return \@out;
	}
	sub DESTROY {}
}

# DA with mutable updated() — exercises FRESH→STALE→FRESH cache transitions
{
	package TransUpdDA;
	use parent -norequire, 'TransDA';
	sub set_updated { $_[0]->{updated} = $_[1]; return $_[0] }
	sub DESTROY {}
}

# WhiteBox subclass to call _cache_fresh() (Sub::Protected method)
{
	package Database::Join::TransBox;
	use parent -norequire, 'Database::Join';
	sub expose_cache_fresh { my $self = shift; return $self->_cache_fresh(@_) }
}

# ---------------------------------------------------------------------------
# Shared constants
# ---------------------------------------------------------------------------

Readonly::Scalar my $JC => 'entry';

Readonly::Hash my %ERR => (
	no_dbs          => qr/At least one Database::Abstraction object is required/,
	remove_join_col => qr/Cannot remove join_column/,
	invalid_db      => qr/databases\[\d+\] does not support/,
	join_col_absent => qr/join_column "[^"]*" is absent from databases/,
);

# Standard two-DA fixture: primary (name), secondary (score), left join.
sub _mk_join {
	my %o = @_;
	my $p = TransDA->new(
		cols => [$JC, 'name'],