view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

BEGIN {
	eval { require Database::Abstraction };
	plan skip_all => 'Database::Abstraction required' if $@;
	plan tests => 70;
	use_ok('Database::Join');
}

# ---------------------------------------------------------------------------
# Readonly attack payloads and structural constants
# ---------------------------------------------------------------------------
Readonly::Scalar my $JC          => 'entry';    # canonical join column
Readonly::Scalar my $K_ALPHA     => 'k001';
Readonly::Scalar my $K_BETA      => 'k002';
Readonly::Scalar my $K_GAMMA     => 'k003';
Readonly::Scalar my $KEY_ZERO    => '0';        # false-but-defined join key

Readonly::Scalar my $ERR_NO_DBS      => qr/At least one Database::Abstraction/;
Readonly::Scalar my $ERR_INVALID_DB  => qr/is not a Database::Abstraction/;
Readonly::Scalar my $ERR_MISSING_JC  => qr/is absent from databases/;
Readonly::Scalar my $ERR_REMOVE_JC   => qr/Cannot remove join_column/;
Readonly::Scalar my $ERR_PRIVATE     => qr/cannot call private method/;
Readonly::Scalar my $ERR_UNKNOWN_COL => qr/unknown column/;
Readonly::Scalar my $ERR_QUERY       => qr/query\(\) chained builder is not supported/;
Readonly::Scalar my $ERR_EXECUTE     => qr/execute\(\) raw SQL is not supported/;
Readonly::Scalar my $ERR_HEAP        => qr/\(join_map\[0\] must be a string\)/;

# ---------------------------------------------------------------------------
# MockEdgeDA: configurable in-process stub with explicit failure modes.
#
# Constructor options:
#   cols      => \@list     -- columns() return value
#   rows      => \@hrefs    -- data for selectall_arrayref
#   id        => 'colname'  -- internal primary-key field (_autoload_pk source)
#   updated   => $epoch     -- updated() return value
#   schema    => \%or_undef -- schema() return value (undef to simulate failure)
#   return    => $anything  -- literal return from selectall_arrayref (overrides rows)
#   croak_msg => 'text'     -- selectall_arrayref will croak with this message
# ---------------------------------------------------------------------------
## no critic (Modules::ProhibitMultiplePackages)
{
	package MockEdgeDA;
	use parent -norequire, 'Database::Abstraction';
	use Carp qw(croak);

	sub new {
		my ($class, %args) = @_;
		return bless {
			id      => $args{id}        // 'entry',
			_cols   => $args{cols}      // ['entry'],
			_rows   => $args{rows}      // [],
			_schema => $args{schema},           # deliberately no default -- undef is valid input
			_ts     => $args{updated}   // 1_000_000,
			_return => $args{return},
			_do_ret => (exists $args{return}),  # distinguish return=>undef from absent key
			_croak  => $args{croak_msg},
		}, $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) = @_;
		croak($self->{_croak})   if $self->{_croak};
		return $self->{_return}  if $self->{_do_ret};
		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 }
				}
			} elsif (defined $val) {
				@rows = grep { defined $_->{$col} && $_->{$col} eq $val } @rows;
			} else {
				@rows = grep { !defined $_->{$col} } @rows;
			}
		}
		return \@rows;
	}

	sub DESTROY {}
}

# MutateCriteriaDA: simulates a hostile DA that mutates the criteria hashref
# it receives.  Used to prove that the broadcast shallow-copy mechanism
# prevents one DA from corrupting the criteria delivered to sibling databases.
{
	package MutateCriteriaDA;
	use parent -norequire, 'Database::Abstraction';

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

	sub columns   { return $_[0]->{_cols} }
	sub schema    { return {} }
	sub updated   { return 1 }
	sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		# HOSTILE: overwrite the '>' operator inside the entry criteria hashref to
		# attempt to corrupt sibling databases' criteria for the same broadcast key.
		if (ref($criteria) eq 'HASH' && ref($criteria->{entry}) eq 'HASH') {
			$criteria->{entry}{'>'} = 999_999;
		}
		return $self->{_rows};
	}

	sub DESTROY {}
}

# ---------------------------------------------------------------------------
# Helper: build a minimal two-DB join with stock fixtures.
# Returns ($join, $primary_da, $secondary_da).
# ---------------------------------------------------------------------------
sub _minimal_join {
	my (%opts) = @_;
	my $prim = MockEdgeDA->new(
		cols => ['entry', 'name'],
		rows => [
			{ entry => $K_ALPHA, name => 'Alice' },
			{ entry => $K_BETA,  name => 'Bob'   },
		],
	);
	my $sec = MockEdgeDA->new(
		cols => ['entry', 'score'],
		rows => [
			{ entry => $K_ALPHA, score => 90 },
			{ entry => $K_BETA,  score => 70 },
		],
	);
	my $j = Database::Join->new(
		databases   => [$prim, $sec],
		join_column => $JC,
		%opts,
	);
	return ($j, $prim, $sec);
}

# ===========================================================================
# Section 1: Constructor hostility
# ===========================================================================

subtest 'constructor: empty databases arrayref croaks error_no_databases' => sub {
	# An empty arrayref satisfies the type check but fails the emptiness guard.
	throws_ok { Database::Join->new(databases => []) }
		$ERR_NO_DBS, 'empty databases => [] croaks';
};

subtest 'constructor: undef element in databases croaks error_invalid_db' => sub {
	throws_ok { Database::Join->new(databases => [undef]) }
		$ERR_INVALID_DB, 'databases => [undef] croaks';
};

subtest 'constructor: unblessed scalar in databases croaks' => sub {
	throws_ok { Database::Join->new(databases => [42]) }