view release on metacpan or  search on metacpan

t/domain.t  view on Meta::CPAN

#!/usr/bin/perl

# Domain tests for Database::Join using Equivalence Partitioning (EP) and
# Boundary Value Analysis (BVA).  Each parameter's valid and invalid partitions
# are tested with representative values; exact boundary edges are exercised
# wherever a numerical range, array size, or string length applies.

use strict;
use warnings;

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

use_ok('Database::Join');

# ---------------------------------------------------------------------------
# Inline test double: configurable in-memory Database::Abstraction subclass.
# Supports equality filtering and operator hashrefs (>, <, >=, <=, !=).
# ---------------------------------------------------------------------------
{
	package DomainDA;
	use parent -norequire, 'Database::Abstraction';

	Readonly::Scalar my $UPDATED => '2026-01-01';

	sub new {
		my ($class, %args) = @_;
		return bless {
			cols    => $args{cols}    // ['entry'],
			rows    => $args{rows}    // [],
			id      => $args{id}      // 'entry',
			updated => $args{updated} // $UPDATED,
			schema  => $args{schema}  // {},
		}, $class;
	}

	sub columns { return $_[0]->{cols} }
	sub schema  { return $_[0]->{schema} }
	sub updated { return $_[0]->{updated} }

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		$criteria //= {};
		my @results;
		ROW: for my $row (@{ $self->{rows} }) {
			for my $col (keys %{$criteria}) {
				my $val = $criteria->{$col};
				if (ref $val eq 'HASH') {
					for my $op (keys %{$val}) {
						my $rhs = $val->{$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 ($op eq '>=') { next ROW unless defined $row->{$col} && $row->{$col} >= $rhs }
						elsif ($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 $val) {
					next ROW if defined $row->{$col};
				} else {
					next ROW unless defined $row->{$col} && $row->{$col} eq $val;
				}
			}
			push @results, { %{$row} };
		}
		return \@results;
	}

	sub DESTROY {}
}

# ---------------------------------------------------------------------------
# Wrong-class sentinel: blessed but not a Database::Abstraction subclass.
# ---------------------------------------------------------------------------
{
	package WrongClass;
	sub new { return bless {}, shift }
}

# ---------------------------------------------------------------------------
# Constants — no magic strings in test bodies.
# ---------------------------------------------------------------------------

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

Readonly::Scalar my $LONG_COLNAME => 'x' x 255;	# 255-char boundary for join_column length

Readonly::Hash my %ERR => (
	no_databases     => qr/At least one Database::Abstraction object is required/,
	invalid_db       => qr/databases\[\d+\] is not a Database::Abstraction object/,
	join_col_missing => qr/join_column "[^"]*" is absent from databases\[\d+\]/,
	join_col_refval  => qr/join_column "\(join_map\[\d+\] must be a string\)" is absent from databases\[\d+\]/,
	remove_join_col  => qr/Cannot remove join_column/,
	unknown_col      => qr/Column "[^"]+" is not present in any configured database/,
);

# Shared two-DB fixture with overlapping key set {k1, k2}.
sub _dbs {
	my $p = DomainDA->new(
		cols => [$JC, 'name'],